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

fixedd bigint bugs

Browse Source
This commit is contained in:
hyung-hwan 2014-02-25 16:10:46 +00:00
parent 998f5a2e55
commit 7fccdc5f85
3 changed files with 69 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -252,17 +252,7 @@ package body Bigint is
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;
Z.Half_Word_Slot(Last) := Carry;
Pop_Tops (Interp.all, 3);
return Z;
@ -272,49 +262,42 @@ package body Bigint is
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;
T: Object_Word;
Borrowed_Word: constant Object_Word := Object_Word(Object_Half_Word'Last) + 1;
Borrow: Object_Half_Word := 0;
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;
A := X;
B := Y;
pragma Assert (not Is_Less_Unsigned(A, B)); -- The caller must ensure that X >= Y
Z := Make_Bigint (Interp.Self, Last);
Borrow := 0;
Z := Make_Bigint (Interp.Self, A.Size); -- Assume X.Size >= Y.Size.
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
T := Object_Word(B.Half_Word_Slot(I)) + Object_Word(Borrow);
if Object_Word(A.Half_Word_Slot(I)) >= T then
Z.Half_Word_Slot(I) := A.Half_Word_Slot(I) - Object_Half_Word(T);
Borrow := 0;
Z.Half_Word_Slot(I) := Object_Half_Word(T);
else
Z.Half_Word_Slot(I) := Object_Half_Word(Borrowed_Word + Object_Word(A.Half_Word_Slot(I)) - T);
Borrow := 1;
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
if A.Half_Word_Slot(I) >= Borrow then
Z.Half_Word_Slot(I) := A.Half_Word_Slot(I) - Object_Half_Word(Borrow);
Borrow := 0;
Z.Half_Word_Slot(I) := Object_Half_Word(T);
else
Z.Half_Word_Slot(I) := Object_Half_Word(Borrowed_Word + Object_Word(A.Half_Word_Slot(I)) - Object_Word(Borrow));
Borrow := 1;
end if;
end loop;
pragma Assert (Borrow = 0);
return Z;
end Subtract_Unsigned;
@ -370,6 +353,13 @@ package body Bigint is
Pop_Tops (Interp.all, 3);
return Z;
end Multiply_Unsigned;
function Divide_Unsigned (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is
begin
return null;
end Divide_Unsigned;
-----------------------------------------------------------------------------
function Add (Interp: access Interpreter_Record;
@ -466,5 +456,32 @@ package body Bigint is
return Normalize(Interp, Z);
end Multiply;
function Divide (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Object_Pointer is
Z: Object_Pointer;
A: Object_Pointer := X;
B: Object_Pointer := Y;
Sign: Object_Sign;
begin
Divide_Integers (Interp, A, B, Z);
if Z /= null then
return Z;
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;
Z := Divide_Unsigned (Interp, A, B);
Z.Sign := Sign;
return Normalize(Interp, Z);
end Divide;
end Bigint;

9
lib/h2-scheme.adb
View File

@ -2695,9 +2695,12 @@ A := Make_Bigint (Interp.Self, Value => 16#FFFF_00000001#);
--B := Make_Bigint (Interp.Self, Value => 16#FFFF_0000000F#);
B := Make_Bigint (Interp.Self, Value => 16#FFFFFF_00000001#);
B.sign := Negative_Sign;
--A := Bigint.Subtract (Interp.Self, integer_to_pointer(16), B);
--A := Bigint.Multiply (Interp.Self, B, integer_to_pointer(2));
A := Bigint.Add (Interp.Self, integer_to_pointer(object_integer'first), integer_to_pointer(-1));
A := Make_Bigint (Interp.Self, Size => 10);
A.Half_Word_Slot(10) := 16#FFFFFFFF#;
--A := Bigint.Multiply (Interp.Self, A, integer_to_pointer(2));
A := Bigint.Add (Interp.Self, A, A);
print (interp, A);
Pop_tops (Interp, 2);
end;

10
lib/h2-scheme.ads
View File

@ -305,7 +305,11 @@ package H2.Scheme is
pragma Inline (Integer_To_Pointer);
pragma Inline (Character_To_Pointer);
pragma Inline (Byte_To_Pointer);
-- this caused GNAT 4.6.3 to end up with an internal bug when used in the generirc Plain_Integer_Op function.
-- let me comment it out temporarily.
--pragma Inline (Pointer_To_Integer);
pragma Inline (Pointer_To_Character);
pragma Inline (Pointer_To_Byte);
@ -466,11 +470,13 @@ package H2.Scheme is
Source: in Object_Character_Array) return Object_Pointer;
function Make_Bigint (Interp: access Interpreter_Record;
Size: Half_Word_Object_Size) return Object_Pointer;
Size: in Half_Word_Object_Size) return Object_Pointer;
function Make_Bigint (Interp: access Interpreter_Record;
Value: Object_Integer) return Object_Pointer;
Value: in Object_Integer) return Object_Pointer;
-- Copy as many Half_Word_Slots as Last from the Source
-- and create a Bigint object.
function Make_Bigint (Interp: access Interpreter_Record;
Source: in Object_Pointer;
Last: in Half_Word_Object_Size) return Object_Pointer;