diff --git a/lib/h2-scheme-bigint.adb b/lib/h2-scheme-bigint.adb index 694ce42..c5af6f2 100644 --- a/lib/h2-scheme-bigint.adb +++ b/lib/h2-scheme-bigint.adb @@ -49,13 +49,21 @@ 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 + function Make_Word (L: in Object_Half_Word; + H: in Object_Half_Word) return Object_Word is + W: Object_Word; + R: Word_Record; + for R'Address use W'Address; begin - if X.Sign /= Y.Sign then - return X.Sign = Negative_Sign; - end if; + R.Low := L; + R.High := H; + 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); + begin if X.Size /= Y.Size then return X.Size < Y.Size; end if; @@ -67,6 +75,15 @@ package body Bigint is end loop; return Standard.False; + end Is_Less_Unsigned; + + 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; + return Is_Less_Unsigned (X, Y); end Is_Less; function Is_Equal (X: in Object_Pointer; @@ -77,9 +94,48 @@ package body Bigint is 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 + function Is_Zero (X: in Object_Pointer) return Standard.Boolean is + begin + 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 + begin + case X.Size is + when 1 => + if X.Sign = Negative_Sign then + return Integer_To_Pointer(-Object_Integer(X.Half_Word_Slot(1))); + else + return Integer_To_Pointer(Object_Integer(X.Half_Word_Slot(1))); + end if; + when 2 => + declare + W: Object_Word := Make_Word (X.Half_Word_Slot(1), X.Half_Word_Slot(2)); + begin + 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; + end case; + + end Normalize; + + 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)); @@ -94,7 +150,7 @@ package body Bigint is Push_Top (Interp.all, B'Unchecked_Access); Push_Top (Interp.all, Z'Unchecked_Access); - if X.Size > Y.Size then + if X.Size >= Y.Size then A := X; B := Y; Last := X.Size + 1; @@ -141,11 +197,11 @@ end loop; end; Pop_Tops (Interp.all, 3); return Z; - end Add; + end Add_Unsigned; - function Subtract (Interp: access Interpreter_Record; - X: in Object_Pointer; - Y: in Object_Pointer) return Object_Pointer is + function Subtract_Unsigned (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; @@ -155,7 +211,7 @@ end; Push_Top (Interp.all, B'Unchecked_Access); Push_Top (Interp.all, Z'Unchecked_Access); - if X.Size > Y.Size then + if X.Size >= Y.Size then A := X; B := Y; Last := X.Size; @@ -190,7 +246,7 @@ end; end if; end loop; -ada.text_io.put_line ("-------------"); +ada.text_io.put_line ("------------SUBTRACT-"); declare package Int_IO is new ada.text_io.modular_IO(object_half_word); begin @@ -200,7 +256,120 @@ ada.text_io.new_line; end loop; end; return Z; - end Subtract; + end Subtract_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; + B: aliased Object_Pointer; + begin + if Is_Integer(X) and then Is_Integer(Y) then + declare + G: Object_Integer := Pointer_To_Integer(X); + 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 + if A.Sign = Negative_Sign then + Z := Subtract (Interp, B, A); + else + Z := Subtract (Interp, A, B); + end if; + else + Z := Add_Unsigned (Interp, A, B); + Z.Sign := A.Sign; + end if; + + Pop_Tops (Interp.all, 2); + 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; + B: aliased Object_Pointer; + begin + if Is_Integer(X) and then Is_Integer(Y) then + declare + G: Object_Integer := Pointer_To_Integer(X); + 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 + Z := Add_Unsigned (Interp, A, B); + Z.Sign := A.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); + --Z.Sign := Object_Sign'Val(not Object_Sign'Pos(A.Sign)); -- opposite A.Sign + if A.Sign = Negative_Sign then + Z.Sign := Positive_Sign; + else + Z.Sign := Negative_Sign; + end if; + else + Z := Subtract_Unsigned (Interp, A, B); + Z.Sign := A.Sign; + end if; + end if; + + Pop_Tops (Interp.all, 2); + return Normalize(Z); + end Subtract; end Bigint; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index e828f14..454feb3 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -2659,8 +2659,10 @@ 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#0000_0000000F#); -A := Bigint.Subtract (Interp.Self, A, B); +B := Make_Bigint (Interp.Self, Value => 16#FFFF_0000000F#); +--A := Bigint.Subtract (Interp.Self, integer_to_pointer(16), B); +A := Bigint.Subtract (Interp.Self, B, integer_to_pointer(16)); +print (interp, A); Pop_tops (Interp, 2); end; Ada.Text_IO.Put_LINE ("=== BYE ==="); diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 48fa8d8..509ad07 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -467,6 +467,9 @@ package H2.Scheme is function Make_Bigint (Interp: access Interpreter_Record; Size: Half_Word_Object_Size) return Object_Pointer; + function Make_Bigint (Interp: access Interpreter_Record; + Value: Object_Integer) return Object_Pointer; + -- ----------------------------------------------------------------------------- @@ -579,9 +582,12 @@ private function Get_Low (W: Object_Word) return Object_Half_Word; function Get_High (W: Object_Word) return Object_Half_Word; + function Make_Word (L: Object_Half_Word; + H: Object_Half_Word) return Object_Word; pragma Inline (Get_High); pragma Inline (Get_Low); + pragma Inline (Make_Word); function Add (Interp: access Interpreter_Record; X: in Object_Pointer;