diff --git a/lib/h2-scheme-bigint.adb b/lib/h2-scheme-bigint.adb index c9901af..694ce42 100644 --- a/lib/h2-scheme-bigint.adb +++ b/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(Y) or else Is_Bigint(Y)); + --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)); - 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 - --end if; + Push_Top (Interp.all, A'Unchecked_Access); + Push_Top (Interp.all, B'Unchecked_Access); + Push_Top (Interp.all, Z'Unchecked_Access); - --Z := Make_Bigint (Interp, X.Size - return null; + if X.Size > Y.Size then + 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; + diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 02e757a..e828f14 100644 --- a/lib/h2-scheme.adb +++ b/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 diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index b9adfb0..48fa8d8 100644 --- a/lib/h2-scheme.ads +++ b/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;