diff --git a/lib/h2-scheme-bigint.adb b/lib/h2-scheme-bigint.adb index 4a87d7b..d4077b6 100644 --- a/lib/h2-scheme-bigint.adb +++ b/lib/h2-scheme-bigint.adb @@ -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; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index f6f2bb0..e7d498f 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -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; diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index c5687d0..5fd76bd 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -305,7 +305,11 @@ package H2.Scheme is pragma Inline (Integer_To_Pointer); pragma Inline (Character_To_Pointer); pragma Inline (Byte_To_Pointer); - --pragma Inline (Pointer_To_Integer); + + -- 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;