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

aalmost finished string-to-bigint conversion

Browse Source
This commit is contained in:
hyung-hwan
2014-03-25 16:43:46 +00:00
parent 64d69c36e5
commit 112f136318
4 changed files with 423 additions and 215 deletions
Download Patch File Download Diff File Expand all files Collapse all files

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

@ -51,7 +51,7 @@ package body Bigint is
Block_Divisors: array (Object_Radix) of Block_Divisor_Record;
Block_Divisors_Initialized: Standard.Boolean := Standard.False;
-----------------------------------------------------------------------------
-------------------------------------------------------------------------
function Get_Low (W: in Object_Word) return Object_Half_Word is
R: Word_Record;
@ -100,7 +100,7 @@ package body Bigint is
when 1 =>
Word.all := Object_Word(X.Half_Word_Slot(1));
when 2 =>
Word.all := Make_Word(X.Half_Word_Slot(1), X.Half_Word_Slot(2));
Word.all := Make_Word(X.Half_Word_Slot(1), X.Half_Word_Slot(2));
when others =>
return Standard.False;
end case;
@ -133,7 +133,7 @@ package body Bigint is
Length := Len;
end Convert_Word_To_Text;
-----------------------------------------------------------------------------
-------------------------------------------------------------------------
function Is_Less_Unsigned_Array (X: in Object_Half_Word_Array;
XS: in Half_Word_Object_Size;
@ -190,7 +190,7 @@ package body Bigint is
return X.Size = 1 and then X.Half_Word_Slot(1) = 1;
end Is_One_Unsigned;
-----------------------------------------------------------------------------
-------------------------------------------------------------------------
function Copy_Upto (Interp: access Interpreter_Record;
X: in Object_Pointer;
Last: in Half_Word_Object_Size) return Object_Pointer is
@ -268,7 +268,7 @@ package body Bigint is
return Copy_Upto(Interp, X, Last);
end Normalize;
-----------------------------------------------------------------------------
-------------------------------------------------------------------------
generic
with function Operator (X: in Object_Integer;
@ -287,6 +287,9 @@ package body Bigint is
begin
if Is_Integer(A) and then Is_Integer(B) then
declare
pragma Unsuppress (Range_Check);
pragma Unsuppress (Overflow_Check);
G: Object_Integer := Pointer_To_Integer(A);
H: Object_Integer := Pointer_To_Integer(B);
begin
@ -296,6 +299,7 @@ package body Bigint is
return;
exception
when Constraint_Error =>
-- TODO: don't count on Constraint_Error exception.
Push_Top (Interp, A'Unchecked_Access);
Push_Top (Interp, B'Unchecked_Access);
-- TODO: allocate A and B from a non-GC heap.
@ -327,7 +331,7 @@ package body Bigint is
procedure Multiply_Integers is new Plain_Integer_Op (Operator => "*");
procedure Divide_Integers is new Plain_Integer_Op (Operator => "/");
-----------------------------------------------------------------------------
-------------------------------------------------------------------------
function Half_Word_Bit_Position (Pos: in Standard.Positive) return Standard.Natural is
pragma Inline (Half_Word_Bit_Position);
@ -354,7 +358,7 @@ package body Bigint is
BA(Half_Word_Bit_Position(Pos)) := Bit;
end Set_Half_Word_Bit;
-----------------------------------------------------------------------------
-------------------------------------------------------------------------
function Shift_Half_Word_Left (W: in Object_Half_Word;
Bits: in Standard.Natural) return Object_Half_Word is
@ -378,7 +382,7 @@ package body Bigint is
return W / (2 ** Bits);
end Shift_Half_Word_Right;
-----------------------------------------------------------------------------
-------------------------------------------------------------------------
procedure Shift_Left_Unsigned_Array (X: in out Object_Half_Word_Array;
XS: in Half_Word_Object_Size;
@ -451,7 +455,7 @@ package body Bigint is
X(XS - Half_Word_Object_Size(Word_Shifts) + 1 .. XS) := (others => 0);
end Shift_Right_Unsigned_Array;
-----------------------------------------------------------------------------
-------------------------------------------------------------------------
procedure Add_Unsigned_Array (X: in Object_Half_Word_Array;
XS: in Half_Word_Object_Size;
@ -592,6 +596,7 @@ package body Bigint is
Carry := High;
end loop;
Z(XS + I) := Carry;
end if;
end loop;
@ -780,7 +785,7 @@ package body Bigint is
R := Dend;
end Divide_Unsigned_2;
-----------------------------------------------------------------------------
-------------------------------------------------------------------------
procedure Add (Interp: in out Interpreter_Record;
X: in Object_Pointer;
@ -917,10 +922,75 @@ package body Bigint is
R := D;
end Divide;
procedure To_String (Interp: in out Interpreter_Record;
X: in Object_Pointer;
Radix: in Object_Radix;
Z: out Object_Pointer) is
-------------------------------------------------------------------------
function Compare_Bigint_And_Bigint (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Integer is
begin
if Is_Equal(X, Y) then
return 0;
elsif Is_Less(X, Y) then
return -1;
else
return 1;
end if;
end Compare_Bigint_And_Bigint;
function Compare_Bigint_And_Integer (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Integer is
YW: Object_Word := Object_Word(Pointer_To_Integer(Y));
Size: Object_Size;
begin
if YW > Object_Word(Object_Half_Word'Last) then
Size := 2;
else
Size := 1;
end if;
declare
YY: aliased Object_Record (Kind => Half_Word_Object, Size => Size);
begin
YY.Tag := Bigint_Object;
YY.Half_Word_Slot(1) := Get_Low(YW);
if YY.Size >= 2 then
YY.Half_Word_Slot(2) := Get_High(YW);
end if;
return Compare_Bigint_And_Bigint (Interp, X, YY'Unchecked_Access);
end;
end Compare_Bigint_And_Integer;
function Compare (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Integer is
begin
if Is_Bigint(X) then
if Is_Bigint(Y) then
return Compare_Bigint_And_Bigint (Interp, X, Y);
else
return Compare_Bigint_And_Integer (Interp, X, Y);
end if;
else
if Is_Bigint(Y) then
return -Compare_Bigint_And_Integer (Interp, Y, X);
else
if Pointer_To_Integer(X) = Pointer_To_Integer(Y) then
return 0;
elsif Pointer_To_Integer(X) < Pointer_To_Integer(Y) then
return -1;
else
return 1;
end if;
end if;
end if;
end Compare;
-------------------------------------------------------------------------
function To_String (Interp: access Interpreter_Record;
X: in Object_Pointer;
Radix: in Object_Radix) return Object_Pointer is
W: aliased Object_Word;
Sign: aliased Object_Sign;
begin
@ -941,18 +1011,17 @@ package body Bigint is
Len := Len + 1;
Buf(Len) := Ch.Minus_Sign;
end if;
Z := Make_String(Interp.Self, Source => Buf(1 .. Len), Invert => Standard.True);
return Make_String(Interp, Source => Buf(1 .. Len), Invert => Standard.True);
end;
return;
end if;
-- Otherwise, do it in a hard way.
declare
B: aliased Object_Record (Kind => Half_Word_Object, Size => 2);
A: aliased Object_Pointer;
B: aliased Object_Pointer;
R: aliased Object_Pointer;
Q: aliased Object_Pointer;
Z: Object_Pointer;
-- TODO: optimize the buffer size depending on the radix value.
subtype Static_Buffer is Object_Character_Array (1 .. 16 * Half_Word_Bits + 1);
@ -989,28 +1058,30 @@ package body Bigint is
end;
end if;
Push_Top (Interp, Q'Unchecked_Access);
Push_Top (Interp, R'Unchecked_Access);
Push_Top (Interp, B'Unchecked_Access);
Push_Top (Interp, A'Unchecked_Access);
-- Create a block divisor object.
B.Tag := Bigint_Object;
B.Half_Word_Slot := (1 => BD.Low, 2 => BD.High);
Push_Top (Interp.all, Q'Unchecked_Access);
Push_Top (Interp.all, R'Unchecked_Access);
Push_Top (Interp.all, A'Unchecked_Access);
-- Clone the value to convert
A := Copy_Upto(Interp.Self, X, X.Size);
-- Create a block divisor using the value gotten above.
B := Make_Bigint(Interp.Self, Size => 2);
B.Half_Word_Slot(1) := BD.Low;
B.Half_Word_Slot(2) := BD.High;
A := Copy_Upto(Interp, X, X.Size);
-- Remember the sign to produce the sign symbol later
Sign := A.Sign;
A.Sign := Positive_Sign;
AS := A.Size;
Q := Make_Bigint(Interp.Self, Size => A.Size);
R := Make_Bigint(Interp.Self, Size => A.Size);
Q := Make_Bigint(Interp, Size => A.Size);
R := Make_Bigint(Interp, Size => A.Size);
loop
ada.text_io.put ("A => ");
print (interp.all, A);
ada.text_io.put ("B => ");
print (interp.all, B'Unchecked_Access);
-- Get a word block to convert
if Is_Less_Unsigned_Array (B.Half_Word_Slot, B.Size, A.Half_Word_Slot, AS) then
Divide_Unsigned_Array (A.Half_Word_Slot, AS, B.Half_Word_Slot, B.Size, Q.Half_Word_Slot, R.Half_Word_Slot);
@ -1019,6 +1090,8 @@ package body Bigint is
else
R := A; -- The last block
end if;
ada.text_io.put ("R => ");
print (interp.all, R);
-- Translate up to 2 half-words to a full word.
if R.Size = 1 then
@ -1026,7 +1099,7 @@ package body Bigint is
else
W := Make_Word(R.Half_Word_Slot(1), R.Half_Word_Slot(2));
end if;
ada.text_io.put_line ("WORD => " & w'img);
Convert_Word_To_Text (W, Radix, Buf(Totlen + 1 .. Buf'Last), Seglen);
Totlen := Totlen + Seglen;
@ -1038,23 +1111,24 @@ package body Bigint is
Totlen := Totlen + 1;
Buf(Totlen) := Object_Character'Val(Object_Character'Pos(Ch.Zero));
end loop;
end loop;
Pop_Tops (Interp, 4);
Pop_Tops (Interp.all, 3);
if Sign = Negative_Sign then
Totlen := Totlen + 1;
Buf(Totlen) := Ch.Minus_Sign;
end if;
Z := Make_String(Interp.Self, Source => Buf(1 .. Totlen), Invert => Standard.True);
Z := Make_String(Interp.Self, Source => Buf(1 .. Totlen), Invert => Standard.True);
-- TODO: Move dynamic_buf to interpreter_Record.
if Dynamic_Buf /= null then
Pool.Deallocate (Dynamic_Buf);
end if;
return Z;
exception
when others =>
if Dynamic_Buf /= null then
@ -1065,39 +1139,42 @@ package body Bigint is
end To_String;
procedure From_String (Interp: in out Interpreter_Record;
X: in Object_Character_Array;
Radix: in Object_Radix;
Z: out Object_Pointer) is
function From_String (Interp: access Interpreter_Record;
X: in Object_Character_Array;
Radix: in Object_Radix) return Object_Pointer is
function Get_Digit_Value (C: in Object_Character) return Object_Integer is
Pos: Object_Integer;
begin
Pos := Object_Character'Pos(C);
case Pos is
when Ch.Pos.Zero .. Ch.Pos.Nine =>
return Pos - Ch.Pos.Zero;
Pos := Pos - Ch.Pos.Zero;
when Ch.Pos.LC_A .. Ch.Pos.LC_Z =>
return Pos - Ch.Pos.LC_A + 10;
Pos := Pos - Ch.Pos.LC_A + 10;
when Ch.Pos.UC_A .. Ch.Pos.UC_Z =>
return Pos - Ch.Pos.UC_A + 10;
Pos := Pos - Ch.Pos.UC_A + 10;
when others =>
return -1;
Pos := -1;
end case;
if Pos not in 0 .. Object_Integer(Radix) - 1 then
raise Numeric_String_Error;
end if;
return Pos;
end Get_Digit_Value;
Sign: Object_Sign;
Idx: Object_Size;
ZI: Object_Size;
Pos: Object_Word;
W: Object_Word;
BDLen: Object_Size renames Block_Divisors(Radix).Length;
Digit_Len: Object_Size;
NDigits: Object_Size;
B: Object_Pointer;
DV: Object_Integer;
begin
-- Find the first digit while remembering the sign
Sign := Positive_Sign;
@ -1111,87 +1188,111 @@ package body Bigint is
end if;
end if;
pragma Assert (Idx < X'Last); -- the caller ensure at least 1 digit
if Idx >= X'Last then
pragma Assert (Idx <= X'Last); -- the caller ensure at least 1 digit
if Idx > X'Last then
-- No digits in the string.
-- TODO: raise exception
Z := Integer_To_Pointer(0);
return;
--return Integer_To_Pointer(0);
raise Numeric_String_Error;
end if;
-- Search backward to find the last non-zero digit
-- Find the first non-zero digit
while Idx <= X'Last loop
exit when X(Idx) /= Ch.Zero;
Idx := Idx + 1;
end loop;
if Idx > X'Last then
Z := Integer_To_Pointer(0);
return;
-- All digits are zeros.
return Integer_To_Pointer(0);
end if;
Digit_Len := X'Last - Idx + 1; -- number of meaningful digits
W := 0;
while Idx <= X'Last loop
DV := Get_Digit_Value(X(Idx));
pragma Assert (DV in 0 .. Object_Integer(Radix));
W := W * Radix + Object_Word(DV);
NDigits := X'Last - Idx + 1; -- number of effective digits
exit when W > Object_Word(Object_Integer'Last);
-- Attemp to perform conversion within the range of Object_Integer.
declare
OW: Object_Word;
I: Object_Integer;
begin
W := 0;
while Idx <= X'Last loop
OW := W;
W := W * Radix + Object_Word(Get_Digit_Value(X(Idx)));
Idx := Idx + 1;
end loop;
if Idx > X'Last then
-- Processed all digits
declare
I: Object_Integer := Object_Integer(W);
begin
if Sign = Negative_Sign then
I := -I;
-- Exit if the accumulated value can't be represented
-- in an Object_Integer.
if W > Object_Word(Object_Integer'Last) or else W <= OW then
W := OW;
goto Huge;
end if;
Z := Integer_To_Pointer(I);
end;
return;
end if;
B := Make_Bigint(Interp.Self, Size => ((Digit_Len + BDLen - 1) / BDLen) * 2 + 1000); -- TODO: is it the right size?
Idx := Idx + 1;
end loop;
-- Processed all digits. The value can fit
-- into an Object_Integer.
I := Object_Integer(W);
ada.text_io.put_line ("SWITING TO BIGINT" & B.Size'Img & " IDX => " & Idx'Img);
--I := 0;
--while Idx <= X'Last loop
-- begin
-- I := I * Object_Integer(Radix) + Get_Digit_Value(X(Idx));
-- exception
-- when Constraint_Error =>
-- W := Object_Word(I);
-- goto Huge;
-- end;
-- Idx := Idx + 1;
--end loop;
ZI := 1;
B.Half_Word_Slot(ZI) := Get_Low(W);
W := Object_Word(Get_High(W));
while Idx <= X'Last loop
DV := Get_Digit_Value(X(Idx));
pragma Assert (DV in 0 .. Object_Integer(Radix));
W := W * Radix + Object_Word(DV);
if W > Object_Word(Object_Half_Word'Last) then
ZI := ZI + 1;
B.Half_Word_Slot(ZI) := Get_Low(W);
W := Object_Word(Get_High(W));
if Sign = Negative_Sign then
I := -I;
end if;
return Integer_To_Pointer(I);
end;
Idx := Idx + 1;
end loop;
<<Huge>>
-- TODO: Optimizations if Radix 2, 4, 16. For there radix, conversion can be done in chunk.
while W > 0 loop
ZI := ZI + 1;
B.Half_Word_Slot(ZI) := Get_Low(W);
W := Object_Word(Get_High(W));
end loop;
-- The input string is too large to be converted to an Object_Integer.
B := Make_Bigint(Interp, Size => ((NDigits + BDLen - 1) / BDLen) * 2 + 1); -- TODO: is it the right size?
declare
C: Object_Pointer;
RB: aliased Object_Record (Kind => Half_Word_Object, Size => 1);
begin
RB.Tag := Bigint_Object;
RB.Half_Word_Slot(1) := Object_Half_Word(Radix);
C := Make_Bigint(Interp, Size => B.Size);
B.Half_Word_Slot(1) := Get_Low(W);
B.Half_Word_Slot(2) := Get_High(W);
while Idx <= X'Last loop
declare
DVB: aliased Object_Record (Kind => Half_Word_Object, Size => 1);
begin
DVB.Tag := Bigint_Object;
DVB.Half_Word_Slot(1) := Object_Half_Word(Get_Digit_Value(X(Idx)));
ada.text_io.put ("B =>");
print (interp.all, B);
ada.text_io.put ("RB =>");
print (interp.all, RB'Unchecked_Access);
Multiply_Unsigned_Array (B.Half_Word_Slot, Count_Effective_Array_Slots(B.Half_Word_Slot, B.Size), RB.Half_Word_Slot, RB.Size, C.Half_Word_Slot);
B.Half_Word_Slot := (others => 0);
Add_Unsigned_Array (C.Half_Word_Slot, Count_Effective_Array_Slots(C.Half_Word_Slot, B.Size), DVB.Half_Word_Slot, DVB.Size, B.Half_Word_Slot);
C.Half_Word_Slot := (others => 0);
end;
print (interp.all, B);
Idx := Idx + 1;
end loop;
end;
B.Sign := Sign;
Z := Normalize(Interp.Self, B);
return Normalize(Interp.Self, B);
end From_String;
-----------------------------------------------------------------------------
-------------------------------------------------------------------------
function Get_Block_Divisor (Radix: in Object_Radix) return Block_Divisor_Record is
V, W: Object_Word;
Len: Object_Size;
@ -1201,18 +1302,27 @@ ada.text_io.put_line ("SWITING TO BIGINT" & B.Size'Img & " IDX => " & Idx'Img);
loop
V := W * Object_Word(Radix);
if V = W then
Len := Len + 1;
W := V;
exit;
elsif V < W then
exit;
end if;
--if V = W then
-- Len := Len + 1;
-- W := V;
-- exit;
--elsif V < W then
-- -- Overflow
-- exit;
--end if;
exit when V <= W;
Len := Len + 1;
W := V;
if Radix = 10 then
ada.text_io.put_line ("BLOCK_DIVISOR XX=> " & w'img);
end if;
end loop;
if Radix = 10 then
ada.text_io.put_line ("BLOCK_DIVISOR => " & w'img);
end if;
return (Low => Get_Low(W), High => Get_High(W), Length => Len);
end Get_Block_Divisor;

239
lib/h2-scheme-execute-apply.adb
View File

@ -282,105 +282,178 @@ Ada.Text_IO.Put_Line ("STRING EXPECTED FOR STRING=?");
-- -------------------------------------------------------------
-- Arithmetic procedures
-- -------------------------------------------------------------
function Is_Numeric (X: in Object_Pointer) return Standard.Boolean is
pragma Inline (Is_Numeric);
begin
return Is_Integer(X) or else Is_Bigint(X);
end Is_Numeric;
procedure Apply_Add_Procedure is
Ptr: Object_Pointer := Args;
Num: Object_Integer := 0; -- TODO: support BIGNUM
Ptr: aliased Object_Pointer := Args;
Num: Object_Pointer;
Car: Object_Pointer;
begin
Push_Top (Interp, Ptr'Unchecked_Access);
Num := Integer_To_Pointer(0);
while Is_Cons(Ptr) loop
-- TODO: check if car is an integer or bignum or something else.
-- if something else, error
Car := Get_Car(Ptr);
if not Is_Integer(Car) then
Ada.Text_IO.Put ("NOT INTEGER FOR ADD"); Print (Interp, Car);
Ptr := Get_Cdr(Ptr);
if not Is_Numeric(Car) then
Ada.Text_IO.Put ("NOT NUMERIC FOR ADD"); Print (Interp, Car);
raise Evaluation_Error;
end if;
Num := Num + Pointer_To_Integer(Car);
Ptr := Get_Cdr(Ptr);
Bigint.Add (Interp, Num, Car, Num);
end loop;
Return_Frame (Interp, Integer_To_Pointer(Num));
Pop_Tops (Interp, 1);
Return_Frame (Interp, Num);
end Apply_Add_Procedure;
procedure Apply_Subtract_Procedure is
Ptr: Object_Pointer := Args;
Num: Object_Integer := 0; -- TODO: support BIGNUM
Ptr: aliased Object_Pointer := Args;
Num: Object_Pointer;
Car: Object_Pointer;
begin
if Is_Cons(Ptr) then
Push_Top (Interp, Ptr'Unchecked_Access);
Car := Get_Car(Ptr);
if not Is_Integer(Car) then
Ptr := Get_Cdr(Ptr);
if not Is_Numeric(Car) then
raise Evaluation_Error;
end if;
Num := Pointer_To_Integer(Car);
Num := Car;
while Is_Cons(Ptr) loop
Car := Get_Car(Ptr);
Ptr := Get_Cdr(Ptr);
if not Is_Numeric(Car) then
raise Evaluation_Error;
end if;
Bigint.Subtract (Interp, Num, Car, Num);
end loop;
Pop_Tops (Interp, 1);
else
Ada.Text_IO.Put_line ("NO ARGUMETNS FOR SUBNTRATION");
raise Evaluation_Error;
end if;
Return_Frame (Interp, Num);
end Apply_Subtract_Procedure;
procedure Apply_Multiply_Procedure is
Ptr: aliased Object_Pointer := Args;
Num: Object_Pointer;
Car: Object_Pointer;
begin
Push_Top (Interp, Ptr'Unchecked_Access);
Num := Integer_To_Pointer(1);
while Is_Cons(Ptr) loop
Car := Get_Car(Ptr);
Ptr := Get_Cdr(Ptr);
if not Is_Numeric(Car) then
Ada.Text_IO.Put ("NOT NUMERIC FOR MULTIPLY"); Print (Interp, Car);
raise Evaluation_Error;
end if;
Bigint.Multiply (Interp, Num, Car, Num);
end loop;
Pop_Tops (Interp, 1);
Return_Frame (Interp, Num);
end Apply_Multiply_Procedure;
procedure Apply_Quotient_Procedure is
Ptr: aliased Object_Pointer := Args;
Num: Object_Pointer;
Car: Object_Pointer;
Rmn: Object_Pointer;
begin
if Is_Cons(Ptr) then
Push_Top (Interp, Ptr'Unchecked_Access);
Car := Get_Car(Ptr);
Ptr := Get_Cdr(Ptr);
if not Is_Numeric(Car) then
raise Evaluation_Error;
end if;
Num := Car;
while Is_Cons(Ptr) loop
-- TODO: check if car is an integer or bignum or something else.
-- if something else, error
Car := Get_Car(Ptr);
if not Is_Integer(Car) then
Ptr := Get_Cdr(Ptr);
if not Is_Numeric(Car) then
Ada.Text_IO.Put ("NOT INTEGER FOR QUOTIENT"); Print (Interp, Car);
raise Evaluation_Error;
end if;
Num := Num - Pointer_To_Integer(Car);
Ptr := Get_Cdr(Ptr);
Bigint.Divide (Interp, Num, Car, Num, Rmn);
end loop;
Pop_Tops (Interp, 1);
else
Ada.Text_IO.Put_line ("NO ARGUMETNS FOR QUOTIENT");
raise Evaluation_Error;
end if;
Return_Frame (Interp, Integer_To_Pointer(Num));
end Apply_Subtract_Procedure;
procedure Apply_Multiply_Procedure is
Ptr: Object_Pointer := Args;
Num: Object_Integer := 1; -- TODO: support BIGNUM
Car: Object_Pointer;
begin
while Is_Cons(Ptr) loop
-- TODO: check if car is an integer or bignum or something else.
-- if something else, error
Car := Get_Car(Ptr);
if not Is_Integer(Car) then
Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
raise Evaluation_Error;
end if;
Num := Num * Pointer_To_Integer(Car);
Ptr := Get_Cdr(Ptr);
end loop;
Return_Frame (Interp, Integer_To_Pointer(Num));
end Apply_Multiply_Procedure;
procedure Apply_Quotient_Procedure is
Ptr: Object_Pointer := Args;
Num: Object_Integer := 1; -- TODO: support BIGNUM
Car: Object_Pointer;
begin
while Is_Cons(Ptr) loop
-- TODO: check if car is an integer or bignum or something else.
-- if something else, error
Car := Get_Car(Ptr);
if not Is_Integer(Car) then
Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
raise Evaluation_Error;
end if;
Num := Num * Pointer_To_Integer(Car);
Ptr := Get_Cdr(Ptr);
end loop;
Return_Frame (Interp, Integer_To_Pointer(Num));
Return_Frame (Interp, Num);
end Apply_Quotient_Procedure;
procedure Apply_Remainder_Procedure is
Ptr: aliased Object_Pointer := Args;
Num: Object_Pointer;
Car: Object_Pointer;
Quo: Object_Pointer;
begin
if Is_Cons(Ptr) then
Push_Top (Interp, Ptr'Unchecked_Access);
Car := Get_Car(Ptr);
Ptr := Get_Cdr(Ptr);
if not Is_Numeric(Car) then
raise Evaluation_Error;
end if;
Num := Car;
while Is_Cons(Ptr) loop
-- TODO: check if car is an integer or bignum or something else.
-- if something else, error
Car := Get_Car(Ptr);
Ptr := Get_Cdr(Ptr);
if not Is_Numeric(Car) then
Ada.Text_IO.Put ("NOT INTEGER FOR QUOTIENT"); Print (Interp, Car);
raise Evaluation_Error;
end if;
Bigint.Divide (Interp, Num, Car, Quo, Num);
end loop;
Pop_Tops (Interp, 1);
else
Ada.Text_IO.Put_line ("NO ARGUMETNS FOR QUOTIENT");
raise Evaluation_Error;
end if;
Return_Frame (Interp, Num);
end Apply_Remainder_Procedure;
-- -------------------------------------------------------------
-- Comparions procedures
-- -------------------------------------------------------------
generic
with function Validate (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean;
with function Compare (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean;
with function Validate (X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Boolean;
with function Compare (X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Boolean;
procedure Apply_Compare_Procedure;
procedure Apply_Compare_Procedure is
-- TODO: support other values
Ptr: Object_Pointer := Args;
X: Object_Pointer;
Y: Object_Pointer;
@ -395,7 +468,7 @@ Ada.Text_IO.Put ("NOT INTEGER FOR MULTIPLY"); Print (Interp, Car);
Y := Get_Car(Ptr);
if not Validate(X, Y) then
ADA.TEXT_IO.PUT_LINE ("NON INTEGER FOR COMPARISION");
ADA.TEXT_IO.PUT_LINE ("INVALID TYPE FOR COMPARISION");
raise Evaluation_Error;
end if;
@ -415,40 +488,40 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
end if;
end Apply_Compare_Procedure;
function Validate_Numeric (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
function Validate_Numeric (X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Boolean is
begin
return Is_Integer(X) and then Is_Integer(Y);
return Is_Numeric(X) and then Is_Numeric(Y);
end Validate_Numeric;
function Equal_To (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
function Equal_To (X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Boolean is
begin
return Pointer_To_Integer(X) = Pointer_To_Integer(Y);
return Bigint.Compare (Interp.Self, X, Y) = 0;
end Equal_To;
function Greater_Than (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
function Greater_Than (X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Boolean is
begin
return Pointer_To_Integer(X) > Pointer_To_Integer(Y);
return Bigint.Compare (Interp.Self, X, Y) > 0;
end Greater_Than;
function Less_Than (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
function Less_Than (X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Boolean is
begin
return Pointer_To_Integer(X) < Pointer_To_Integer(Y);
return Bigint.Compare (Interp.Self, X, Y) < 0;
end Less_Than;
function Greater_Or_Equal (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
function Greater_Or_Equal (X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Boolean is
begin
return Pointer_To_Integer(X) >= Pointer_To_Integer(Y);
return Bigint.Compare (Interp.Self, X, Y) >= 0;
end Greater_Or_Equal;
function Less_Or_Equal (X: in Object_Pointer; Y: in Object_Pointer) return Standard.Boolean is
-- TODO: support BIGNUM, OTHER DATA TYPES
function Less_Or_Equal (X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Boolean is
begin
return Pointer_To_Integer(X) <= Pointer_To_Integer(Y);
return Bigint.Compare (Interp.Self, X, Y) <= 0;
end Less_Or_Equal;
procedure Apply_N_EQ_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Equal_To);
@ -457,8 +530,6 @@ Ada.Text_IO.Put_line ("TOO FEW ARGUMETNS FOR COMPARISON");
procedure Apply_N_GE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Greater_Or_Equal);
procedure Apply_N_LE_Procedure is new Apply_Compare_Procedure (Validate_Numeric, Less_Or_Equal);
-- -------------------------------------------------------------
-- Closure
-- -------------------------------------------------------------
@ -684,9 +755,7 @@ begin
when N_Quotient_Procedure =>
Apply_Quotient_Procedure;
when N_Remainder_Procedure =>
--Apply_Remainder_Procedure;
ada.text_io.put_line ("NOT IMPLEMENTED");
raise Evaluation_Error;
Apply_Remainder_Procedure;
when N_Subtract_Procedure =>
Apply_Subtract_Procedure;

37
lib/h2-scheme.adb
View File

@ -457,7 +457,8 @@ package body H2.Scheme is
case Token.Kind is
when Integer_Token =>
-- TODO: bignum
return String_To_Integer_Pointer(Token.Value.Ptr.all(1..Token.Value.Last));
--return String_To_Integer_Pointer(Token.Value.Ptr.all(1..Token.Value.Last));
return Bigint.From_String (Interp, Token.Value.Ptr.all(1..Token.Value.Last), 10);
when Character_Token =>
pragma Assert (Token.Value.Last = 1);
@ -2680,6 +2681,15 @@ Ada.Text_IO.Put_Line (">>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> LOOP ITERATION XXXXXX C
when Stream_End_Error =>
-- this is not a real error. this indicates the end of input stream.
declare
q: object_Pointer;
begin
--q := bigint.from_string (interp.self, String_To_Object_Character_Array("20000000000000000000000000000000000000000"), 10);
q := bigint.from_string (interp.self, String_To_Object_Character_Array("20000000000"), 10);
q := bigint.to_string (interp.self, q, 10);
print (interp, q);
end;
goto SKIP;
declare
A: aliased Object_Pointer;
B: aliased Object_Pointer;
begin
@ -2716,22 +2726,37 @@ begin
ada.text_io.put ("Q => "); print (interp, Q);
ada.text_io.put ("R => "); print (interp, R);
bigint.to_string (interp, Q, 16,r);
--bigint.to_string (interp, integer_to_pointer(-2), 10, r);
r := bigint.to_string (interp.self, Q, 16);
--r := bigint.to_string (interp.self, integer_to_pointer(-2), 10);
print (interp, r);
--bigint.to_string (interp, r, 10, r);
end;
Pop_tops (Interp, 2);
end;
declare
a: object_pointer;
b: object_pointer;
begin
a := Make_Bigint (Interp.Self, Size => 3);
b := Make_Bigint (Interp.Self, Size => 1);
a.half_word_slot(1) := Object_Half_Word'Last;
a.half_word_slot(2) := Object_Half_Word'Last;
b.half_word_Slot(1) := 16#10#;
bigint.multiply (interp, a, b, a);
print (interp, a);
end;
declare
q: object_Pointer;
begin
bigint.from_string (interp, String_To_Object_Character_Array("FFFFFFFFFFFFFFFFFFFFFFFFFFFF1111111AAAA"), 16, q);
bigint.to_string (interp, q, 16, q);
q := bigint.from_string (interp.self, String_To_Object_Character_Array("-FFFFFFFFFFFFFFFFAAAAAAAAAAAAAAAA11111111222222223333333344444444"), 16);
--q := bigint.from_string (interp.self, String_To_Object_Character_Array("-123456789123456789123456789A"), 15, q);
--q := bigint.from_string (interp.self, String_To_Object_Character_Array("123456789012345678901234567890"), 10, q);
--q := bigint.from_string (interp.self, String_To_Object_Character_Array("+123456701234567012345670123456701234567"), 8, q);
q := bigint.to_string (interp.self, q, 16);
print (interp, q);
end;
<<SKIP>>
Ada.Text_IO.Put_LINE ("=== BYE ===");
Pop_Tops (Interp, 1);
if Aliased_Result /= null then

20
lib/h2-scheme.ads
View File

@ -54,6 +54,8 @@ package H2.Scheme is
Internal_Error: exception;
IO_Error: exception;
Divide_By_Zero_Error: exception;
Numeric_String_Error: exception;
type Interpreter_Record is limited private;
type Interpreter_Pointer is access all Interpreter_Record;
@ -632,16 +634,18 @@ private
Y: in Object_Pointer;
Q: out Object_Pointer;
R: out Object_Pointer);
function Compare (Interp: access Interpreter_Record;
X: in Object_Pointer;
Y: in Object_Pointer) return Standard.Integer;
procedure To_String (Interp: in out Interpreter_Record;
X: in Object_Pointer;
Radix: in Object_Radix;
Z: out Object_Pointer);
function To_String (Interp: access Interpreter_Record;
X: in Object_Pointer;
Radix: in Object_Radix) return Object_Pointer;
procedure From_String (Interp: in out Interpreter_Record;
X: in Object_Character_Array;
Radix: in Object_Radix;
Z: out Object_Pointer);
function From_String (Interp: access Interpreter_Record;
X: in Object_Character_Array;
Radix: in Object_Radix) return Object_Pointer;
procedure Initialize;
end Bigint;