hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added some bigint code

Browse Source
This commit is contained in:
hyung-hwan 2014-02-21 16:08:43 +00:00
parent f43fef30c2
commit f78a95283c
3 changed files with 177 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

154
lib/h2-scheme-bigint.adb
View File

@ -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));
Z: Object_Pointer;
--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));
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;

18
lib/h2-scheme.adb
View File

@ -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

14
lib/h2-scheme.ads
View File

@ -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;