added some bigint code

lib/h2-scheme-bigint.adb

@@ -49,20 +49,158 @@ package body Bigint is
 		return R.High;	
 	end Get_High;
 
+	function Is_Less (X: in Object_Pointer;
+	                  Y: in Object_Pointer) return Standard.Boolean is
+	begin
+		if X.Sign /= Y.Sign then
+			return X.Sign = Negative_Sign;
+		end if;
+
+		if X.Size /= Y.Size then
+			return X.Size < Y.Size;
+		end if;
+
+		for I in reverse X.Half_Word_Slot'Range loop
+			if X.Half_Word_Slot(I) /= Y.Half_Word_Slot(I) then
+				return X.Half_Word_Slot(I) < Y.Half_Word_Slot(I);
+			end if;	
+		end loop;
+
+		return Standard.False;
+	end Is_Less;
+
+	function Is_Equal (X: in Object_Pointer;
+	                   Y: in Object_Pointer) return Standard.Boolean is
+	begin
+		return X.Sign = Y.Sign and then 
+		       X.Size = Y.Size and then
+		       X.Half_Word_Slot = Y.Half_Word_Slot;
+	end Is_Equal;
+
 	function Add (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(X) or else Is_Bigint(X));
-		pragma Assert (Is_Integer(Y) or else Is_Bigint(Y));
+		--pragma Assert (Is_Integer(Y) or else Is_Bigint(Y));
+		pragma Assert (Is_Bigint(X));
+		pragma Assert (Is_Bigint(Y));
 
-		Z: Object_Pointer;
+		A, B, Z: aliased Object_Pointer;
-		
+		W: Object_Word;
+		Carry: Object_Half_Word; 
+		Last: Half_Word_Object_Size;
 	begin
-		--if X.Size > Y.Size then
+		Push_Top (Interp.all, A'Unchecked_Access);
-		--end if;
+		Push_Top (Interp.all, B'Unchecked_Access);
+		Push_Top (Interp.all, Z'Unchecked_Access);
 
-		--Z := Make_Bigint (Interp,  X.Size
+		if X.Size > Y.Size then
-		return null;
+			A := X;
+			B := Y;
+			Last := X.Size + 1;
+		else
+			A := Y;
+			B := X;	
+			Last := Y.Size + 1;
+		end if;
+			
+		Z := Make_Bigint (Interp.Self, Last);
+		Carry := 0;
+
+		for I in 1 .. B.Size loop
+			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;
+
+		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;
+
+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;
 
+	function Subtract (Interp: access Interpreter_Record;
+	                   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;
+	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;
+			
+		Z := Make_Bigint (Interp.Self, Last);
+		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;
+			if T < 0 then
+				Borrow := 1;
+				Z.Half_Word_Slot(I) := Object_Half_Word(-T);
+			else
+				Borrow := 0;
+				Z.Half_Word_Slot(I) := Object_Half_Word(T);
+			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
+				Borrow := 0;
+				Z.Half_Word_Slot(I) := Object_Half_Word(T);
+			end if;
+		end loop;
+		
+ada.text_io.put_line ("-------------");
+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;	
+
 end Bigint;
+

lib/h2-scheme.adb

@@ -1383,7 +1383,7 @@ end if;
 	-----------------------------------------------------------------------------
 
 	function Make_Bigint (Interp: access Interpreter_Record;
-	                      Size:   in     Pointer_Object_Size) return Object_Pointer is
+	                      Size:   in     Half_Word_Object_Size) return Object_Pointer is
 		Ptr: Object_Pointer;
 	begin
 		Ptr := Allocate_Half_Word_Object(Interp, Size);
@@ -2647,6 +2647,22 @@ Ada.Text_IO.Put_Line (">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> LOOP ITERATION XXXXXX C
 	exception
 		when Stream_End_Error =>
 			-- this is not a real error. this indicates the end of input stream.
+declare
+A: aliased Object_Pointer;
+B: aliased Object_Pointer;
+begin
+Push_Top (Interp, A'Unchecked_Access);
+Push_Top (Interp, B'Unchecked_Access);
+--A := Make_Bigint (Interp.Self, Value => 16#0FFFFFFF_FFFFFFFF#);
+--B := Make_Bigint (Interp.Self, Value => 16#0FFFFFFF_FFFFFFFF#);
+--for I in 1 .. 11 loop
+--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#0000_0000000F#);
+A := Bigint.Subtract (Interp.Self, A, B);
+Pop_tops (Interp, 2);
+end;
 			Ada.Text_IO.Put_LINE ("=== BYE ===");
 			Pop_Tops (Interp, 1);
 			if Aliased_Result /= null then

lib/h2-scheme.ads

@@ -451,12 +451,22 @@ package H2.Scheme is
 
 	procedure Collect_Garbage (Interp: in out Interpreter_Record);
 
+     procedure Push_Top (Interp: in out Interpreter_Record;
+                         Source: access Object_Pointer);
+
+     procedure Pop_Tops (Interp: in out Interpreter_Record;
+                         Count:  in     Object_Size);
+
+
      function Make_String (Interp: access  Interpreter_Record;
                            Source: in      Object_Character_Array) return Object_Pointer;
 
      function Make_Symbol (Interp: access  Interpreter_Record;
                            Source: in      Object_Character_Array) return Object_Pointer;
 
+	function Make_Bigint (Interp: access Interpreter_Record;
+	                      Size:   Half_Word_Object_Size) return Object_Pointer;
+
 	-- -----------------------------------------------------------------------------
 
 
@@ -577,6 +587,10 @@ private
 		              X:      in     Object_Pointer;
 		              Y:      in     Object_Pointer) return Object_Pointer;
 
+		function Subtract (Interp: access Interpreter_Record;
+		                   X:      in     Object_Pointer;
+		                   Y:      in     Object_Pointer) return Object_Pointer;
+
 	end Bigint;
 
 end H2.Scheme;