added bigint multiplication

lib/h2-scheme-bigint.adb

@@ -13,7 +13,8 @@ package body Bigint is
 		System.Default_Bit_Order = System.Low_Order_First
 	);
 
-	Half_Word_Bits: constant := Object_Pointer_Bits / 2;
+	--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
@@ -35,6 +36,8 @@ package body Bigint is
 	--for Word_Record'Bit_Order use System.High_Order_First;
 	--for Word_Record'Bit_Order use System.Low_Order_First;
 
+	-----------------------------------------------------------------------------
+
 	function Get_Low (W: in Object_Word) return Object_Half_Word is
 		R: Word_Record;
 		for R'Address use W'Address;		
@@ -60,6 +63,8 @@ package body Bigint is
 		return W;	
 	end Make_Word;
 
+	-----------------------------------------------------------------------------
+
 	function Is_Less_Unsigned (X: in Object_Pointer;
 	                           Y: in Object_Pointer) return Standard.Boolean is
 		pragma Inline (Is_Less_Unsigned);
@@ -99,9 +104,20 @@ package body Bigint is
 		return X.Size = 1 and then X.Half_Word_Slot(1) = 0;
 	end Is_Zero;
 
-	function Normalize (X: in Object_Pointer) return Object_Pointer is
+	-----------------------------------------------------------------------------
+
+	function Normalize (Interp: access Interpreter_Record;
+	                    X:      in     Object_Pointer) return Object_Pointer is
+		Last: Half_Word_Object_Size := 1;
 	begin
-		case X.Size is
+		for I in reverse 1 .. X.Size loop
+			if X.Half_Word_Slot(I) /= 0 then
+				Last := I;
+				exit;
+			end if;
+		end loop;
+
+		case Last is
 			when 1 =>
 				if X.Sign = Negative_Sign then
 					return Integer_To_Pointer(-Object_Integer(X.Half_Word_Slot(1)));
@@ -115,29 +131,90 @@ package body Bigint is
 					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));
-						else
-							return X;
 						end if;
 					else
 						if W in 0 .. Object_Word(Object_Integer'Last) then
 							return Integer_To_Pointer(Object_Integer(W));
-						else
-							return X;
 						end if;
 					end if;
 				end;
 
 			when others =>
-				return X;
+				null;
 		end case;
 
+		if X.Size = Last then
+			return X;
+		else
+			return Make_Bigint(Interp, X, Last);
+		end if;
+
 	end Normalize;
 
+	-----------------------------------------------------------------------------
+
+	generic
+		with function Operator (X: in Object_Integer; 
+		                        Y: in Object_Integer) return Object_Integer;
+	procedure Plain_Integer_Op (Interp: access Interpreter_Record;
+	                            X:      in out Object_Pointer;
+	                            Y:      in out Object_Pointer;
+	                            Z:      out    Object_Pointer);
+
+	procedure Plain_Integer_Op (Interp: access 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
+				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 =>
+					Push_Top (Interp.all, A'Unchecked_Access);
+					Push_Top (Interp.all, 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, Value => G);	
+					B := Make_Bigint(Interp, Value => H);	
+					Pop_Tops (Interp.all, 2);
+			end;
+		else
+			Push_Top (Interp.all, A'Unchecked_Access);
+			Push_Top (Interp.all, B'Unchecked_Access);
+			if Is_Integer(A) then
+				A := Make_Bigint(Interp, Value => Pointer_To_Integer(A));
+			end if;
+			if Is_Integer(B) then
+				B := Make_Bigint(Interp, Value => Pointer_To_Integer(B));
+			end if;		
+			Pop_Tops (Interp.all, 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 Add_Unsigned (Interp: access Interpreter_Record;
 	                       X:      in     Object_Pointer;
 	                       Y:      in     Object_Pointer) return Object_Pointer is
-		--pragma Assert (Is_Integer(X) or else Is_Bigint(X));
-		--pragma Assert (Is_Integer(Y) or else Is_Bigint(Y));
 		pragma Assert (Is_Bigint(X));
 		pragma Assert (Is_Bigint(Y));
 
@@ -187,14 +264,6 @@ package body Bigint is
 			end;
 		end if;
 
-declare
-package Int_IO is new ada.text_io.modular_IO(object_half_word); 
-begin
-for I in reverse Z.Half_Word_Slot'Range loop
-int_io.put (Z.Half_Word_Slot(I), base=>16);
-ada.text_io.new_line;
-end loop;
-end;
 		Pop_Tops (Interp.all, 3);
 		return Z;
 	end Add_Unsigned;
@@ -245,53 +314,76 @@ end;
 				Z.Half_Word_Slot(I) := Object_Half_Word(T);
 			end if;
 		end loop;
-		
+
-ada.text_io.put_line ("------------SUBTRACT-");
-declare
-package Int_IO is new ada.text_io.modular_IO(object_half_word); 
-begin
-for I in reverse Z.Half_Word_Slot'Range loop
-int_io.put (Z.Half_Word_Slot(I), base=>16);
-ada.text_io.new_line;
-end loop;
-end;
 		return Z;
 	end Subtract_Unsigned;	
 
+	function Multiply_Unsigned (Interp: access Interpreter_Record;
+	                            X:      in     Object_Pointer;
+	                            Y:      in     Object_Pointer) return Object_Pointer is
+		A, B, Z: aliased Object_Pointer;
+		W: Object_Word;
+		Low, High: Object_Half_Word;
+		Carry: Object_Half_Word;
+		Index: Half_Word_Object_Size;
+	begin
+		Push_Top (Interp.all, A'Unchecked_Access);
+		Push_Top (Interp.all, B'Unchecked_Access);
+		Push_Top (Interp.all, Z'Unchecked_Access);
+
+		A := X;
+		B := Y;
+		Z := Make_Bigint (Interp.Self, A.Size + B.Size);
+
+		--for I in B.Half_Word_Slot'Range loop
+		for I in 1 .. B.Size loop
+			if B.Half_Word_Slot(I) = 0 then
+				Z.Half_Word_Slot(A.Size + I) := 0;
+			else
+				Carry := 0;	
+
+				--for J in A.Half_Word_Slot'Range loop
+				for J in 1 .. A.Size loop
+					W := Object_Word(A.Half_Word_Slot(J)) * Object_Word(B.Half_Word_Slot(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.Half_Word_Slot(Index);
+					if Low < Z.Half_Word_SLot(Index) then
+						High := High + 1;
+					end if;
+					Z.Half_Word_Slot(Index) := Low;
+
+					Carry := High;
+				end loop;
+
+				Z.Half_Word_Slot(A.Size + I) := Carry;
+			end if;
+		end loop;
+
+		Pop_Tops (Interp.all, 3);
+		return Z;
+	end Multiply_Unsigned;
+	-----------------------------------------------------------------------------
+
 	function Add (Interp: access Interpreter_Record;
 	              X:      in     Object_Pointer;
 	              Y:      in     Object_Pointer) return Object_Pointer is
 
 		Z: Object_Pointer;
-		A: aliased Object_Pointer;
+		A: Object_Pointer := X;
-		B: aliased Object_Pointer;
+		B: Object_Pointer := Y;
+		Sign: Object_Sign;
 	begin
-		if Is_Integer(X) and then Is_Integer(Y) then
+		Add_Integers (Interp, A, B, Z);
-			declare
+		if Z /= null then
-				G: Object_Integer := Pointer_To_Integer(X);
+			return Z;
-				H: Object_Integer := Pointer_To_Integer(Y);
-				T: Object_Integer;
-			begin
-				T := G + H;
-				return Integer_To_Pointer(T);
-			exception
-				when Constraint_Error =>
-					Push_Top (Interp.all, A'Unchecked_Access);
-					Push_Top (Interp.all, B'Unchecked_Access);
-					A := Make_Bigint(Interp, G);	
-					B := Make_Bigint(Interp, H);	
-			end;
-		else
-			Push_Top (Interp.all, A'Unchecked_Access);
-			Push_Top (Interp.all, B'Unchecked_Access);
-			A := X;
-			B := Y;
-			if Is_Integer(A) then
-				A := Make_Bigint(Interp, Pointer_To_Integer(A));	
-			end if;
-			if Is_Integer(B) then
-				B := Make_Bigint(Interp, Pointer_To_Integer(B));	
-			end if;		
 		end if;
 
 		if A.Sign /= B.Sign then
@@ -301,75 +393,78 @@ end;
 				Z := Subtract (Interp, A, B);
 			end if;
 		else
+			Sign := A.Sign;
 			Z := Add_Unsigned (Interp, A, B);
-			Z.Sign := A.Sign;
+			Z.Sign := Sign;
 		end if;
 
-		Pop_Tops (Interp.all, 2);
+		return Normalize(Interp, Z);
-		return Normalize(Z);
 	end Add;
 
 	function Subtract (Interp: access Interpreter_Record;
 	                   X:      in     Object_Pointer;
 	                   Y:      in     Object_Pointer) return Object_Pointer is
 		Z: Object_Pointer;
-		A: aliased Object_Pointer;
+		A: Object_Pointer := X;
-		B: aliased Object_Pointer;
+		B: Object_Pointer := Y;
+		Sign: Object_Sign;
 	begin
-		if Is_Integer(X) and then Is_Integer(Y) then
+		Subtract_Integers (Interp, A, B, Z);
-			declare
+		if Z /= null then
-				G: Object_Integer := Pointer_To_Integer(X);
+			return Z;
-				H: Object_Integer := Pointer_To_Integer(Y);
-				T: Object_Integer;
-			begin
-				T := G + H;
-				return Integer_To_Pointer(T);
-			exception
-				when Constraint_Error =>
-					Push_Top (Interp.all, A'Unchecked_Access);
-					Push_Top (Interp.all, B'Unchecked_Access);
-					A := Make_Bigint(Interp, G);	
-					B := Make_Bigint(Interp, H);	
-			end;
-		else
-			Push_Top (Interp.all, A'Unchecked_Access);
-			Push_Top (Interp.all, B'Unchecked_Access);
-			A := X;
-			B := Y;
-			if Is_Integer(A) then
-				A := Make_Bigint(Interp, Pointer_To_Integer(A));	
-			end if;
-			if Is_Integer(B) then
-				B := Make_Bigint(Interp, Pointer_To_Integer(B));	
-			end if;		
 		end if;
 
 		if A.Sign /= B.Sign then
+			Sign := A.Sign;
 			Z := Add_Unsigned (Interp, A, B);
-			Z.Sign := A.Sign;
+			Z.Sign := Sign;
-			--if A.Sign = Negative_Sign then
-			--	Z.Sign := Negative_Sign;
-			--	Z.Sign := Negative_Sign;
-			--else
-			--	Z := Add_Unsigned (Interp, A, B);
-			--end if;
 		else
 			if Is_Less_Unsigned(A, B) then	
-				Z := Subtract_Unsigned (Interp, B, A);
+				--Sign := Object_Sign'Val(not Object_Sign'Pos(A.Sign)); -- opposite A.Sign
-				--Z.Sign := Object_Sign'Val(not Object_Sign'Pos(A.Sign)); -- opposite A.Sign
 				if A.Sign = Negative_Sign then
-					Z.Sign := Positive_Sign;
+					Sign := Positive_Sign;
 				else
-					Z.Sign := Negative_Sign;
+					Sign := Negative_Sign;
 				end if;
+				Z := Subtract_Unsigned (Interp, B, A);
+				Z.Sign := Sign;
 			else
+				Sign := A.Sign;
 				Z := Subtract_Unsigned (Interp, A, B);
-				Z.Sign := A.Sign;
+				Z.Sign := Sign;
 			end if;
 		end if;
 
-		Pop_Tops (Interp.all, 2);
+		return Normalize(Interp, Z);
-		return Normalize(Z);
 	end Subtract;
+
+	function Multiply (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
+		Multiply_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 := Multiply_Unsigned (Interp, A, B);
+		Z.Sign := Sign;
+
+		return Normalize(Interp, Z);
+	end Multiply;
+
 end Bigint;
 

lib/h2-scheme.adb

@@ -273,12 +273,12 @@ package body H2.Scheme is
 		return Get_Pointer_Type(Pointer) = Object_Pointer_Type_Byte;
 	end Is_Byte;
 
-	function Integer_To_Pointer (Int: in Object_Integer) return Object_Pointer is
+	function Integer_To_Pointer (Value: in Object_Integer) return Object_Pointer is
 		Pointer: Object_Pointer;
 		Word: Object_Word;
 		for Word'Address use Pointer'Address;
 	begin
-		if Int < 0 then
+		if Value < 0 then
 			-- change the sign of a negative number.
 			-- '-Int' may violate the range of Object_Integer
 			-- if it is Object_Integer'First. So I add 1 to 'Int'
@@ -287,22 +287,21 @@ package body H2.Scheme is
 			--Word := Object_Word (-(Int + 1)) + 1;
 
 			-- Let me use Object_Signed_Word instead of the trick shown above
-			Word := Object_Word(-Object_Signed_Word(Int));
+			Word := Object_Word(-Object_Signed_Word(Value));
 
 			-- shift the number to the left by 2 and
 			-- set the highest bit on by force.
 			Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Integer) or (2 ** (Word'Size - 1));
 		else
-			Word := Object_Word(Int);
+			Word := Object_Word(Value);
 			-- Shift 'Word' to the left by 2 and set the integer mark.
 			Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Integer);
 		end if;
 
-		--return Object_Label_To_Object_Pointer (Word);
 		return Pointer;
 	end Integer_To_Pointer;
 
-	function Character_To_Pointer (Char: in Object_Character) return Object_Pointer is
+	function Character_To_Pointer (Value: in Object_Character) return Object_Pointer is
 		Pointer: Object_Pointer;
 		Word: Object_Word;
 		for Word'Address use Pointer'Address;
@@ -313,18 +312,17 @@ package body H2.Scheme is
 		--   or short. In reality, the last Unicode code point assigned is far
 		--   less than #16#7FFFFFFF# as of this writing. So I should not be
 		--   worried about it for the time being.
-		Word := Object_Character'Pos(Char);
+		Word := Object_Character'Pos(Value);
 		Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Character);
-		--return Object_Label_To_Object_Pointer (Word);
 		return Pointer;
 	end Character_To_Pointer;
 
-	function Byte_To_Pointer (Byte: in Object_Byte) return Object_Pointer is
+	function Byte_To_Pointer (Value: in Object_Byte) return Object_Pointer is
 		Pointer: Object_Pointer;
 		Word: Object_Word;
 		for Word'Address use Pointer'Address;
 	begin
-		Word := Object_Word(Byte);
+		Word := Object_Word(Value);
 		Word := (Word * (2 ** Object_Pointer_Type_Bits)) or Object_Word(Object_Pointer_Type_Byte);
 		return Pointer;
 	end Byte_To_Pointer;
@@ -339,7 +337,7 @@ package body H2.Scheme is
 	--end Pointer_To_Word;
 
 	function Pointer_To_Integer (Pointer: in Object_Pointer) return Object_Integer is
-		Word: Object_Word := Pointer_To_Word (Pointer);
+		Word: Object_Word := Pointer_To_Word(Pointer);
 	begin
 		if (Word and (2 ** (Word'Size - 1))) /= 0 then
 			-- if the highest bit is set, it's a negative number
@@ -1423,8 +1421,24 @@ end if;
 			Ptr.Sign := Negative_Sign;
 		end if;
 
-ada.text_io.put_line (Object_Half_Word'image(bigint.get_high(w)));
+		return Ptr;
-ada.text_io.put_line (Object_Half_Word'image(bigint.get_low(w)));
+	end Make_Bigint;
+
+	function Make_Bigint (Interp: access Interpreter_Record;
+	                      Source: in     Object_Pointer;
+	                      Last:   in     Half_Word_Object_Size) return Object_Pointer is
+		pragma Assert (Is_Bigint(Source));
+		pragma Assert (Last <= Source.Size);
+
+		X: aliased Object_Pointer := Source;
+		Ptr: Object_Pointer;
+	begin
+		Push_Top (Interp.all, X'Unchecked_Access);
+		Ptr := Allocate_Half_Word_Object(Interp, Last);
+		Ptr.Tag := Bigint_Object;
+		Ptr.Sign := Source.Sign;
+		Ptr.Half_Word_Slot := X.Half_Word_Slot(1 .. Last);
+		Pop_Tops (Interp.all, 1);
 		return Ptr;
 	end Make_Bigint;
 
@@ -2260,6 +2274,25 @@ ada.text_io.put_line (Object_Half_Word'image(bigint.get_low(w)));
 							Ada.Text_IO.Put ("#Array");
 				
 
+						when Bigint_Object => 
+							Ada.Text_IO.Put ("#Bigint(");
+declare
+package Int_IO is new ada.text_io.modular_IO(object_half_word);
+begin
+if Atom.Sign = Negative_Sign then
+ada.text_io.put ("-");
+else
+ada.text_io.put ("+");
+end if;
+for I in reverse Atom.Half_Word_Slot'Range loop
+ada.text_io.put (" ");
+int_io.put (Atom.Half_Word_Slot(I), base=>16);
+end loop;
+end;
+
+							Ada.Text_IO.Put(")");
+
+
 						when Others =>
 							if Atom.Kind = Character_Object then
 								Output_Character_Array (Atom.Character_Slot);
@@ -2659,9 +2692,12 @@ Push_Top (Interp, B'Unchecked_Access);
 --A := Bigint.Add (Interp.Self, A, B);
 --end loop;
 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#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.Subtract (Interp.Self, B, integer_to_pointer(16));
+--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));
 print (interp, A);
 Pop_tops (Interp, 2);
 end;

lib/h2-scheme.ads

@@ -113,6 +113,7 @@ package H2.Scheme is
 	-- -----------------------------------------------------------------------
 	-- What is a better choice? TODO: decide what to use
 	-- -----------------------------------------------------------------------
+
 	-- Let Object_Integer take up as large a space as Object_Pointer
 	-- despite the actual range of Object_Integer.
 	for Object_Integer'Size use Object_Pointer_Bits;
@@ -289,9 +290,9 @@ package H2.Scheme is
 	function Is_Character (Pointer: in Object_Pointer) return Standard.Boolean;
 	function Is_Byte (Pointer: in Object_Pointer) return Standard.Boolean;
 
-	function Integer_To_Pointer (Int: in Object_Integer) return Object_Pointer;
+	function Integer_To_Pointer (Value: in Object_Integer) return Object_Pointer;
-	function Character_To_Pointer (Char: in Object_Character) return Object_Pointer;
+	function Character_To_Pointer (Value: in Object_Character) return Object_Pointer;
-	function Byte_To_Pointer (Byte: in Object_Byte) return Object_Pointer;
+	function Byte_To_Pointer (Value: in Object_Byte) return Object_Pointer;
 
 	function Pointer_To_Integer (Pointer: in Object_Pointer) return Object_Integer;
 	function Pointer_To_Character (Pointer: in Object_Pointer) return Object_Character;
@@ -304,7 +305,7 @@ package H2.Scheme is
 	pragma Inline (Integer_To_Pointer);
 	pragma Inline (Character_To_Pointer);
 	pragma Inline (Byte_To_Pointer);
-	pragma Inline (Pointer_To_Integer);
+	--pragma Inline (Pointer_To_Integer);
 	pragma Inline (Pointer_To_Character);
 	pragma Inline (Pointer_To_Byte);
 
@@ -470,6 +471,10 @@ package H2.Scheme is
 	function Make_Bigint (Interp: access Interpreter_Record;
 	                      Value:  Object_Integer) return Object_Pointer;
 
+	function Make_Bigint (Interp:  access Interpreter_Record;
+	                      Source:  in     Object_Pointer;
+	                      Last:    in     Half_Word_Object_Size) return Object_Pointer;
+
 	-- -----------------------------------------------------------------------------
 
 
@@ -597,6 +602,10 @@ private
 		                   X:      in     Object_Pointer;
 		                   Y:      in     Object_Pointer) return Object_Pointer;
 
+		function Multiply (Interp: access Interpreter_Record;
+		                   X:      in     Object_Pointer;
+		                   Y:      in     Object_Pointer) return Object_Pointer;
+
 	end Bigint;
 
 end H2.Scheme;