hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

touched bigint

Browse Source
This commit is contained in:
hyung-hwan 2014-03-04 14:32:49 +00:00
parent 77abff6346
commit 3be78f2cdf
3 changed files with 167 additions and 158 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

202
lib/h2-scheme-bigint.adb
View File

@ -196,12 +196,12 @@ package body Bigint is
generic generic
with function Operator (X: in Object_Integer; with function Operator (X: in Object_Integer;
Y: in Object_Integer) return Object_Integer; Y: in Object_Integer) return Object_Integer;
procedure Plain_Integer_Op (Interp: access Interpreter_Record; procedure Plain_Integer_Op (Interp: in out Interpreter_Record;
X: in out Object_Pointer; X: in out Object_Pointer;
Y: in out Object_Pointer; Y: in out Object_Pointer;
Z: out Object_Pointer); Z: out Object_Pointer);
procedure Plain_Integer_Op (Interp: access Interpreter_Record; procedure Plain_Integer_Op (Interp: in out Interpreter_Record;
X: in out Object_Pointer; X: in out Object_Pointer;
Y: in out Object_Pointer; Y: in out Object_Pointer;
Z: out Object_Pointer) is Z: out Object_Pointer) is
@ -219,25 +219,25 @@ package body Bigint is
return; return;
exception exception
when Constraint_Error => when Constraint_Error =>
Push_Top (Interp.all, A'Unchecked_Access); Push_Top (Interp, A'Unchecked_Access);
Push_Top (Interp.all, B'Unchecked_Access); Push_Top (Interp, B'Unchecked_Access);
-- TODO: allocate A and B from a non-GC heap. -- TODO: allocate A and B from a non-GC heap.
-- I know that pointers returned by Make_Bigint here are short-lived -- 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. -- and not needed after actual operation. non-GC heap is a better choice.
A := Make_Bigint(Interp, Value => G); A := Make_Bigint(Interp.Self, Value => G);
B := Make_Bigint(Interp, Value => H); B := Make_Bigint(Interp.Self, Value => H);
Pop_Tops (Interp.all, 2); Pop_Tops (Interp, 2);
end; end;
else else
Push_Top (Interp.all, A'Unchecked_Access); Push_Top (Interp, A'Unchecked_Access);
Push_Top (Interp.all, B'Unchecked_Access); Push_Top (Interp, B'Unchecked_Access);
if Is_Integer(A) then if Is_Integer(A) then
A := Make_Bigint(Interp, Value => Pointer_To_Integer(A)); A := Make_Bigint(Interp.Self, Value => Pointer_To_Integer(A));
end if; end if;
if Is_Integer(B) then if Is_Integer(B) then
B := Make_Bigint(Interp, Value => Pointer_To_Integer(B)); B := Make_Bigint(Interp.Self, Value => Pointer_To_Integer(B));
end if; end if;
Pop_Tops (Interp.all, 2); Pop_Tops (Interp, 2);
end if; end if;
X := A; X := A;
@ -252,43 +252,51 @@ package body Bigint is
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
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; function Add_Unsigned (Interp: access Interpreter_Record;
X: in Object_Pointer; X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is Y: in Object_Pointer) return Object_Pointer is
A, B: aliased Object_Pointer; A, B: aliased Object_Pointer;
Z: Object_Pointer; Z: Object_Pointer;
W: Object_Word;
Carry: Object_Half_Word := 0;
Last: Half_Word_Object_Size;
begin begin
if X.Size >= Y.Size then if X.Size >= Y.Size then
A := X; A := X;
B := Y; B := Y;
Last := X.Size + 1;
else else
A := Y; A := Y;
B := X; B := X;
Last := Y.Size + 1;
end if; end if;
Push_Top (Interp.all, A'Unchecked_Access); Push_Top (Interp.all, A'Unchecked_Access);
Push_Top (Interp.all, B'Unchecked_Access); Push_Top (Interp.all, B'Unchecked_Access);
Z := Make_Bigint (Interp.Self, Last); Z := Make_Bigint (Interp.Self, A.Size + 1);
Pop_Tops (Interp.all, 2); Pop_Tops (Interp.all, 2);
for I in 1 .. B.Size loop Add_Unsigned_Array (A.Half_Word_Slot, A.Size, B.Half_Word_Slot, B.Size, Z.Half_Word_Slot);
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;
Z.Half_Word_Slot(Last) := Carry;
return Z; return Z;
end Add_Unsigned; end Add_Unsigned;
@ -325,7 +333,6 @@ package body Bigint is
pragma Assert (Borrow = 0); pragma Assert (Borrow = 0);
end Subtract_Unsigned_Array; end Subtract_Unsigned_Array;
function Subtract_Unsigned (Interp: access Interpreter_Record; function Subtract_Unsigned (Interp: access Interpreter_Record;
X: in Object_Pointer; X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is Y: in Object_Pointer) return Object_Pointer is
@ -408,7 +415,7 @@ package body Bigint is
return Z; return Z;
end Multiply_Unsigned; end Multiply_Unsigned;
procedure Divide_Unsigned (Interp: access Interpreter_Record; procedure Divide_Unsigned (Interp: in out Interpreter_Record;
X: in Object_Pointer; X: in Object_Pointer;
Y: in Object_Pointer; Y: in Object_Pointer;
Q: out Object_Pointer; Q: out Object_Pointer;
@ -417,7 +424,6 @@ package body Bigint is
B: aliased Object_Pointer := Y; B: aliased Object_Pointer := Y;
Quo: aliased Object_Pointer; Quo: aliased Object_Pointer;
Remn: aliased Object_Pointer;
Dend: aliased Object_Pointer; -- Dividend Dend: aliased Object_Pointer; -- Dividend
Sor: aliased Object_Pointer; -- Divisor Sor: aliased Object_Pointer; -- Divisor
Tmp: Object_Pointer; Tmp: Object_Pointer;
@ -426,35 +432,24 @@ package body Bigint is
Dend_Size: Half_Word_Object_Size; Dend_Size: Half_Word_Object_Size;
Sor_Size: Half_Word_Object_Size; Sor_Size: Half_Word_Object_Size;
Tmp_Size: Half_Word_Object_Size; Tmp_Size: Half_Word_Object_Size;
Cand_Size: Half_Word_Object_Size;
Cand_W: Object_Word; Cand_W: Object_Word;
Cand: Object_Half_Word_Array (1 .. 2); Cand: Object_Half_Word_Array (1 .. 2);
Cand_Size: Half_Word_Object_Size;
begin begin
pragma Assert (not Is_Less_Unsigned(A, B)); -- The caller must ensure that X >= Y pragma Assert (not Is_Less_Unsigned(A, B)); -- The caller must ensure that X >= Y
-- 823456 / 93 Push_Top (Interp, A'Unchecked_Access);
Push_Top (Interp, B'Unchecked_Access);
-- 823456 930000 : (8 / 9) => 0, Push_Top (Interp, Quo'Unchecked_Access);
-- 823456 93000 : (82 / 9) => 9, Push_Top (Interp, Dend'Unchecked_Access);
-- 9 * 93000 => 837000 Push_Top (Interp, Sor'Unchecked_Access);
-- 837000 > 823456
-- 8 * 93000 => 664000
-- 664000 <= 823456
Push_Top (Interp.all, A'Unchecked_Access);
Push_Top (Interp.all, B'Unchecked_Access);
Push_Top (Interp.all, Quo'Unchecked_Access);
Push_Top (Interp.all, Remn'Unchecked_Access);
Push_Top (Interp.all, Dend'Unchecked_Access);
Push_Top (Interp.all, Sor'Unchecked_Access);
Quo := Make_Bigint (Interp.Self, A.Size); Quo := Make_Bigint (Interp.Self, A.Size);
Remn := Make_Bigint (Interp.Self, A.Size);
Dend := Make_Bigint (Interp.Self, A.Size); Dend := Make_Bigint (Interp.Self, A.Size);
Sor := Make_Bigint (Interp.Self, A.Size); Sor := Make_Bigint (Interp.Self, A.Size);
Tmp := Make_Bigint (Interp.Self, A.Size + B.Size); Tmp := Make_Bigint (Interp.Self, A.Size + 2); -- Is it enough? A.Size + B.Size is safer
Pop_Tops (Interp.all, 6); Pop_Tops (Interp, 5);
Dend_Size := A.Size; Dend_Size := A.Size;
Sor_Size := A.Size; Sor_Size := A.Size;
@ -463,10 +458,10 @@ package body Bigint is
Sor.Half_Word_Slot(1 + Diff .. B.Size + Diff) := B.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 for I in reverse B.Size .. A.Size loop
if Is_Less_Unsigned_Array(Dend.Half_Word_Slot, Dend_Size, Sor.Half_Word_Slot, Sor_Size) then if not Is_Less_Unsigned_Array(Dend.Half_Word_Slot, Dend_Size, Sor.Half_Word_Slot, Sor_Size) then
Quo.Half_Word_Slot(I) := 0;
else
if Dend_Size > 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 := 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_W := Cand_W / Object_Word(Sor.Half_Word_Slot(Sor_Size));
Cand(1) := Get_Low(Cand_W); Cand(1) := Get_Low(Cand_W);
@ -477,21 +472,34 @@ package body Bigint is
Cand_Size := 1; Cand_Size := 1;
end if; end if;
else 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(1) := Dend.Half_Word_Slot(Dend_Size) / Sor.Half_Word_Slot(Sor_Size);
Cand_Size := 1; Cand_Size := 1;
end if; end if;
-- Multiply the divisor and the quotient candidate.
Tmp.Half_Word_Slot := (others => 0); Tmp.Half_Word_Slot := (others => 0);
Multiply_Unsigned_Array (Cand, Cand_Size, Sor.Half_Word_Slot, Sor_Size, Tmp.Half_Word_Slot); Multiply_Unsigned_Array (Cand, Cand_Size, Sor.Half_Word_Slot, Sor_Size, Tmp.Half_Word_Slot);
Tmp_Size := Count_Effective_Slots(Tmp); Tmp_Size := Count_Effective_Slots(Tmp);
-- Check if the divident is less than the multiplication result.
if Is_Less_Unsigned_Array(Dend.Half_Word_Slot, Dend_Size, Tmp.Half_Word_Slot, Tmp_Size) then if Is_Less_Unsigned_Array(Dend.Half_Word_Slot, Dend_Size, Tmp.Half_Word_Slot, Tmp_Size) then
-- If so, decrement the candidate by 1.
Quo.Half_Word_Slot(I) := Cand(1) - 1; Quo.Half_Word_Slot(I) := Cand(1) - 1;
-- Dividend := Dividend - Tmp
Subtract_Unsigned_Array (Dend.Half_Word_Slot, Dend_Size, Tmp.Half_Word_Slot, Tmp_Size, Dend.Half_Word_Slot); 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); Dend_Size := Count_Effective_Slots(Dend);
-- Divident := Dividdent - Divisor
Subtract_Unsigned_Array (Dend.Half_Word_Slot, Dend_Size, Sor.Half_Word_Slot, Sor_Size, Dend.Half_Word_Slot); Subtract_Unsigned_Array (Dend.Half_Word_Slot, Dend_Size, Sor.Half_Word_Slot, Sor_Size, Dend.Half_Word_Slot);
Dend_Size := Count_Effective_Slots(Dend); Dend_Size := Count_Effective_Slots(Dend);
else else
-- If not, the candidate is the right guess.
Quo.Half_Word_Slot(I) := Cand(1); Quo.Half_Word_Slot(I) := Cand(1);
-- Dividend := Dividend - Tmp
Subtract_Unsigned_Array (Dend.Half_Word_Slot, Dend_Size, Tmp.Half_Word_Slot, Tmp_Size, Dend.Half_Word_Slot); 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); Dend_Size := Count_Effective_Slots(Dend);
end if; end if;
@ -505,56 +513,49 @@ package body Bigint is
end loop; end loop;
Q := Quo; Q := Quo;
R := Remn; R := Dend;
end Divide_Unsigned; end Divide_Unsigned;
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
function Add (Interp: access Interpreter_Record; procedure Add (Interp: in out Interpreter_Record;
X: in Object_Pointer; X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is Y: in Object_Pointer;
Z: out Object_Pointer) is
Z: Object_Pointer;
A: Object_Pointer := X; A: Object_Pointer := X;
B: Object_Pointer := Y; B: Object_Pointer := Y;
Sign: Object_Sign; Sign: Object_Sign;
begin begin
Add_Integers (Interp, A, B, Z); Add_Integers (Interp, A, B, Z);
if Z /= null then if Z = null then
return Z;
end if;
if A.Sign /= B.Sign then if A.Sign /= B.Sign then
if A.Sign = Negative_Sign then if A.Sign = Negative_Sign then
Z := Subtract (Interp, B, A); Subtract (Interp, B, A, Z);
else else
Z := Subtract (Interp, A, B); Subtract (Interp, A, B, Z);
end if; end if;
else else
Sign := A.Sign; Sign := A.Sign;
Z := Add_Unsigned (Interp, A, B); Z := Add_Unsigned (Interp.Self, A, B);
Z.Sign := Sign; Z.Sign := Sign;
end if; end if;
Z := Normalize(Interp.Self, Z);
return Normalize(Interp, Z); end if;
end Add; end Add;
function Subtract (Interp: access Interpreter_Record; procedure Subtract (Interp: in out Interpreter_Record;
X: in Object_Pointer; X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is Y: in Object_Pointer;
Z: out Object_Pointer) is
A: Object_Pointer := X; A: Object_Pointer := X;
B: Object_Pointer := Y; B: Object_Pointer := Y;
Z: Object_Pointer;
Sign: Object_Sign; Sign: Object_Sign;
begin begin
Subtract_Integers (Interp, A, B, Z); Subtract_Integers (Interp, A, B, Z);
if Z /= null then if Z = null then
return Z;
end if;
if A.Sign /= B.Sign then if A.Sign /= B.Sign then
Sign := A.Sign; Sign := A.Sign;
Z := Add_Unsigned (Interp, A, B); Z := Add_Unsigned(Interp.Self, A, B);
Z.Sign := Sign; Z.Sign := Sign;
else else
if Is_Less_Unsigned(A, B) then if Is_Less_Unsigned(A, B) then
@ -564,32 +565,28 @@ package body Bigint is
else else
Sign := Negative_Sign; Sign := Negative_Sign;
end if; end if;
Z := Subtract_Unsigned (Interp, B, A); Z := Subtract_Unsigned(Interp.Self, B, A);
Z.Sign := Sign; Z.Sign := Sign;
else else
Sign := A.Sign; Sign := A.Sign;
Z := Subtract_Unsigned (Interp, A, B); Z := Subtract_Unsigned(Interp.Self, A, B);
Z.Sign := Sign; Z.Sign := Sign;
end if; end if;
end if; end if;
Z := Normalize(Interp.Self, Z);
return Normalize(Interp, Z); end if;
end Subtract; end Subtract;
function Multiply (Interp: access Interpreter_Record; procedure Multiply (Interp: in out Interpreter_Record;
X: in Object_Pointer; X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is Y: in Object_Pointer;
Z: out Object_Pointer) is
A: Object_Pointer := X; A: Object_Pointer := X;
B: Object_Pointer := Y; B: Object_Pointer := Y;
Z: Object_Pointer;
Sign: Object_Sign; Sign: Object_Sign;
begin begin
Multiply_Integers (Interp, A, B, Z); Multiply_Integers (Interp, A, B, Z);
if Z /= null then if Z = null then
return Z;
end if;
-- Determine the sign earlier than any object allocation -- Determine the sign earlier than any object allocation
-- to avoid GC side-effects because A and B are not pushed -- to avoid GC side-effects because A and B are not pushed
-- as temporarry object pointers. -- as temporarry object pointers.
@ -598,13 +595,13 @@ package body Bigint is
else else
Sign := Negative_Sign; Sign := Negative_Sign;
end if; end if;
Z := Multiply_Unsigned (Interp, A, B); Z := Multiply_Unsigned (Interp.Self, A, B);
Z.Sign := Sign; Z.Sign := Sign;
Z := Normalize(Interp.Self, Z);
return Normalize(Interp, Z); end if;
end Multiply; end Multiply;
procedure Divide (Interp: access Interpreter_Record; procedure Divide (Interp: in out Interpreter_Record;
X: in Object_Pointer; X: in Object_Pointer;
Y: in Object_Pointer; Y: in Object_Pointer;
Q: out Object_Pointer; Q: out Object_Pointer;
@ -649,15 +646,22 @@ package body Bigint is
C.Sign := Sign; C.Sign := Sign;
D.Sign := Sign; D.Sign := Sign;
Push_Top (Interp.all, C'Unchecked_Access); Push_Top (Interp, C'Unchecked_Access);
Push_Top (Interp.all, D'Unchecked_Access); Push_Top (Interp, D'Unchecked_Access);
C := Normalize(Interp, C); C := Normalize(Interp.Self, C);
D := Normalize(Interp, D); D := Normalize(Interp.Self, D);
Pop_Tops (Interp.all, 2); Pop_Tops (Interp, 2);
Q := C; Q := C;
R := D; R := D;
end Divide; end Divide;
procedure To_String (Interp: in out Interpreter_Record;
X: in Object_Pointer;
Radix: in Object_Half_Word;
Z: out Object_Pointer) is
begin
null;
end To_String;
end Bigint; end Bigint;

23
lib/h2-scheme.adb
View File

@ -2671,22 +2671,25 @@ A := Make_Bigint (Interp.Self, Value => 16#FFFF_00000001#);
B := Make_Bigint(Interp.Self, Value => 16#FFFFFF_00000001#); B := Make_Bigint(Interp.Self, Value => 16#FFFFFF_00000001#);
B.sign := Negative_Sign; B.sign := Negative_Sign;
A := Make_Bigint (Interp.Self, Size => 10); A := Make_Bigint(Interp.Self, Size => 4);
A.Half_Word_Slot(10) := 16#FFFFFFFF#; A.Half_Word_Slot(4) := 16#11FFFFFF#;
A := Bigint.Multiply (Interp.Self, A, integer_to_pointer(2)); Bigint.Multiply(Interp, A, integer_to_pointer(2), A);
A := Bigint.Add (Interp.Self, A, A); Bigint.Add(Interp, A, A, A);
--A := Bigint.Divide (Interp.Self, A, integer_to_pointer(0)); B := Make_Bigint(Interp.Self, Size => 4);
B.Half_Word_Slot(4) := 16#22FFFFFF#;
Bigint.Subtract(Interp, B, integer_to_pointer(1), B);
--A := Bigint.Divide(Interp, A, integer_to_pointer(0));
print (interp, A); print (interp, A);
print (interp, B);
declare declare
q, r: object_Pointer; q, r: object_Pointer;
begin begin
--Bigint.Divide (Interp.Self, integer_to_pointer(-10), integer_to_pointer(6), Q, R); --Bigint.Divide (Interp, integer_to_pointer(-10), integer_to_pointer(6), Q, R);
Bigint.Divide (Interp.Self, A, integer_to_pointer(-2), Q, R); Bigint.Divide (Interp, A, B, Q, R);
print (interp, Q); ada.text_io.put ("Q => "); print (interp, Q);
print (interp, R); ada.text_io.put ("R => "); print (interp, R);
end; end;
Pop_tops (Interp, 2); Pop_tops (Interp, 2);
end; end;

18
lib/h2-scheme.ads
View File

@ -402,7 +402,6 @@ package H2.Scheme is
end case; end case;
end record; end record;
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
-- The nil/true/false object are represented by special pointer values. -- The nil/true/false object are represented by special pointer values.
@ -605,19 +604,22 @@ private
pragma Inline (Get_Low); pragma Inline (Get_Low);
pragma Inline (Make_Word); pragma Inline (Make_Word);
function Add (Interp: access Interpreter_Record; procedure Add (Interp: in out Interpreter_Record;
X: in Object_Pointer; X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer; Y: in Object_Pointer;
Z: out Object_Pointer);
function Subtract (Interp: access Interpreter_Record; procedure Subtract (Interp: in out Interpreter_Record;
X: in Object_Pointer; X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer; Y: in Object_Pointer;
Z: out Object_Pointer);
function Multiply (Interp: access Interpreter_Record; procedure Multiply (Interp: in out Interpreter_Record;
X: in Object_Pointer; X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer; Y: in Object_Pointer;
Z: out Object_Pointer);
procedure Divide (Interp: access Interpreter_Record; procedure Divide (Interp: in out Interpreter_Record;
X: in Object_Pointer; X: in Object_Pointer;
Y: in Object_Pointer; Y: in Object_Pointer;
Q: out Object_Pointer; Q: out Object_Pointer;