fixedd bigint bugs

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;
 
 		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;
+		T: Object_Word;
-		Borrow: Object_Signed_Word; 
+		Borrowed_Word: constant Object_Word := Object_Word(Object_Half_Word'Last) + 1;
-		T: Object_Signed_Word;
+		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;
+		pragma Assert (not Is_Less_Unsigned(A, B)); -- The caller must ensure that X >= Y
-		else
-			A := Y;
-			B := X;	
-			Last := Y.Size;
-		end if;
 			
-		Z := Make_Bigint (Interp.Self, Last);
+		Z := Make_Bigint (Interp.Self, A.Size); -- Assume X.Size >= Y.Size.
-		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;
+			T := Object_Word(B.Half_Word_Slot(I)) + Object_Word(Borrow);
-			if T < 0 then
+			if Object_Word(A.Half_Word_Slot(I)) >= T then
-				Borrow := 1;
+				Z.Half_Word_Slot(I) := A.Half_Word_Slot(I) - Object_Half_Word(T);
-				Z.Half_Word_Slot(I) := Object_Half_Word(-T);
-			else
 				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 A.Half_Word_Slot(I) >= Borrow then
-			if T < 0 then
+				Z.Half_Word_Slot(I) := A.Half_Word_Slot(I) - Object_Half_Word(Borrow);
-				Borrow := 1;
-				Z.Half_Word_Slot(I) := Object_Half_Word(-T);
-			else
 				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;
 

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 := Make_Bigint (Interp.Self, Size => 10);
-A := Bigint.Add (Interp.Self, integer_to_pointer(object_integer'first), integer_to_pointer(-1));
+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;

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);
+
+	-- 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;