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

added the incomplete string-to-bigint conversion procedure

Browse Source
This commit is contained in:
hyung-hwan 2014-03-09 18:01:38 +00:00
parent 57f8b64c2b
commit 64d69c36e5
10 changed files with 271 additions and 74 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
cmd/scheme.adb
View File

@ -29,7 +29,12 @@ procedure scheme is
--File_Stream: Stream.File_Stream_Record := (Name => File_Name'Unchecked_Access);
File_Stream: Stream.File_Stream_Record;
--procedure h2init;
--pragma Import (C, h2init, "h2init");
begin
--h2init;
Ada.Text_Io.Put_Line (S.Object_Word'Image(S.Object_Pointer_Bytes));
S.Open (SI, 2_000_000, Pool'Unchecked_Access);

1
lib/ascii.awk
View File

@ -4,6 +4,7 @@ BEGIN {
printf ("-- Generated with ascii.txt and ascii.awk\n");
printf ("-- Run qseawk -f ascii.awk ascii.txt > h2-ascii.ads for regeneration\n\n");
printf ("generic\n\ttype Character_Type is (<>);\npackage H2.Ascii is\n\n");
printf ("\tpragma Preelaborate (Ascii);\n\n");
printf ("\tpackage Pos is\n");
}

2
lib/h2-ascii.ads
View File

@ -5,6 +5,8 @@ generic
type Character_Type is (<>);
package H2.Ascii is
pragma Preelaborate (Ascii);
package Pos is
NUL : constant := 0;
SOH : constant := 1;

1
lib/h2-pool.ads
View File

@ -13,6 +13,7 @@ generic
Storage_Pool: in Storage_Pool_Pointer := null;
package H2.Pool is
pragma Preelaborate (Pool);
function Allocate (Pool: in Storage_Pool_Pointer := null) return Pointer_Type;

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

@ -39,24 +39,30 @@ package body Bigint is
--for Word_Record'Bit_Order use System.High_Order_First;
--for Word_Record'Bit_Order use System.Low_Order_First;
type Object_Bit is mod 2 ** 1;
--for Object_Bit'Size use 1;
type Half_Word_Bit_Array is array(1 .. Half_Word_Bits) of Object_Bit;
pragma Pack (Half_Word_Bit_Array);
for Half_Word_Bit_Array'Size use Half_Word_Bits;
type Block_Divisor_Record is record
Low: Object_Half_Word; -- low half-word of divisor
High: Object_Half_Word; -- high half-word of divisor
Length: Object_Size; -- number of digits
end record;
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;
for R'Address use W'Address;
for R'Address use W'Address;
begin
return R.Low;
end Get_Low;
function Get_High (W: in Object_Word) return Object_Half_Word is
R: Word_Record;
for R'Address use W'Address;
for R'Address use W'Address;
begin
return R.High;
end Get_High;
@ -65,7 +71,7 @@ package body Bigint is
H: in Object_Half_Word) return Object_Word is
W: Object_Word;
R: Word_Record;
for R'Address use W'Address;
for R'Address use W'Address;
begin
R.Low := L;
R.High := H;
@ -102,7 +108,7 @@ package body Bigint is
end if;
return Standard.True;
end Decode_To_Word;
procedure Convert_Word_To_Text (Word: in Object_Word;
Radix: in Object_Radix;
Buffer: in out Object_Character_Array;
@ -216,17 +222,8 @@ package body Bigint is
function Count_Effective_Slots (X: in Object_Pointer) return Half_Word_Object_Size is
pragma Inline (Count_Effective_Slots);
--Last: Half_Word_Object_Size := 1;
begin
return Count_Effective_Array_Slots (X.Half_Word_Slot, X.Size);
--for I in reverse 1 .. X.Size loop
-- if X.Half_Word_Slot(I) /= 0 then
-- Last := I;
-- exit;
-- end if;
--end loop;
--return Last;
return Count_Effective_Array_Slots(X.Half_Word_Slot, X.Size);
end Count_Effective_Slots;
function Normalize (Interp: access Interpreter_Record;
@ -304,7 +301,7 @@ package body Bigint is
-- TODO: allocate A and B from a non-GC heap.
-- I know that pointers returned by Make_Bigint here are short-lived
-- and not needed after actual operation. non-GC heap is a better choice.
A := Make_Bigint(Interp.Self, Value => G);
A := Make_Bigint(Interp.Self, Value => G);
B := Make_Bigint(Interp.Self, Value => H);
Pop_Tops (Interp, 2);
end;
@ -357,6 +354,8 @@ 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
pragma Inline (Shift_Half_Word_Left);
@ -378,6 +377,8 @@ package body Bigint is
end if;
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;
@ -625,6 +626,19 @@ package body Bigint is
Bit_Pos: Standard.Positive;
RS: Half_Word_Object_Size;
begin
-- Perform binary long division.
-- http://en.wikipedia.org/wiki/Division_algorithm
--Q := 0 initialize quotient and remainder to zero
--R := 0
--for i = n-1...0 do where n is number of bits in N
-- R := R << 1 left-shift R by 1 bit
-- R(0) := X(i) set the least-significant bit of R equal to bit i of the numerator
-- if R >= Y then
-- R = R - Y
-- Q(i) := 1
-- end
--end
Q := (others => 0);
R := (others => 0);
@ -809,12 +823,7 @@ package body Bigint is
Z.Sign := Sign;
else
if Is_Less_Unsigned(A, B) then
--Sign := Object_Sign'Val(not Object_Sign'Pos(A.Sign)); -- opposite A.Sign
if A.Sign = Negative_Sign then
Sign := Positive_Sign;
else
Sign := Negative_Sign;
end if;
Sign := Object_Sign'Val(Object_Bit(Object_Sign'Pos(A.Sign)) + 1); -- opposite A.Sign
Z := Subtract_Unsigned(Interp.Self, B, A);
Z.Sign := Sign;
else
@ -938,17 +947,12 @@ package body Bigint is
return;
end if;
-- Otherwise, do it in the hard way.
-- Otherwise, do it in a hard way.
declare
A: aliased Object_Pointer;
B: aliased Object_Pointer;
R: aliased Object_Pointer;
Q: aliased Object_Pointer;
V: Object_Word;
Radlen: Object_Size; -- Maxiumum length of each word conversion
Totlen: Object_Size := 0; -- Length of total conversion
Seglen: Object_Size; -- Length of each word conversion
AS: Half_Word_Object_Size;
-- TODO: optimize the buffer size depending on the radix value.
subtype Static_Buffer is Object_Character_Array (1 .. 16 * Half_Word_Bits + 1);
@ -959,8 +963,17 @@ package body Bigint is
Static_Buf: aliased Static_Buffer;
Dynamic_Buf: Dynamic_Buffer_Pointer;
Buf: Thin_Object_Character_Array_Pointer;
Totlen: Object_Size := 0; -- Length of total conversion
Seglen: Object_Size; -- Length of each word conversion
AS: Half_Word_Object_Size;
-- BD is the largest multiple of Radix that is less than or
-- equal to Object_Word'Last.
--BD: constant Block_Divisor_Record := Get_Block_Divisor(Radix);
BD: Block_Divisor_Record renames Block_Divisors(Radix);
begin
if X.Size <= 16 then
if X.Size <= 16 then
declare
function Conv is new Ada.Unchecked_Conversion (Static_Buffer_Pointer, Thin_Object_Character_Array_Pointer);
begin
@ -975,24 +988,7 @@ package body Bigint is
Buf := Conv(Dynamic_Buf);
end;
end if;
-- Find the largest multiple of Radix that is less than or
-- equal to Object_Word'Last.
Radlen := 1;
W := Object_Word(Radix);
loop
V := W * Object_Word(Radix);
if V = W then
Radlen := Radlen + 1;
W := V;
exit;
elsif V < W then
exit;
end if;
Radlen := Radlen + 1;
W := V;
end loop;
Push_Top (Interp, Q'Unchecked_Access);
Push_Top (Interp, R'Unchecked_Access);
Push_Top (Interp, B'Unchecked_Access);
@ -1003,8 +999,8 @@ package body Bigint is
-- Create a block divisor using the value gotten above.
B := Make_Bigint(Interp.Self, Size => 2);
B.Half_Word_Slot(1) := Get_Low(W);
B.Half_Word_Slot(2) := Get_High(W);
B.Half_Word_Slot(1) := BD.Low;
B.Half_Word_Slot(2) := BD.High;
-- Remember the sign to produce the sign symbol later
Sign := A.Sign;
@ -1037,7 +1033,8 @@ package body Bigint is
exit when R = A; -- Reached the last block
-- Fill unfilled leading digits with zeros if it's not the last block
for I in Seglen + 1 .. Radlen loop
--for I in Seglen + 1 .. Block_Divisors(Radix).Length loop
for I in Seglen + 1 .. BD.Length loop
Totlen := Totlen + 1;
Buf(Totlen) := Object_Character'Val(Object_Character'Pos(Ch.Zero));
end loop;
@ -1053,7 +1050,8 @@ package body Bigint is
Z := Make_String(Interp.Self, Source => Buf(1 .. Totlen), Invert => Standard.True);
if Dynamic_Buf /= null then
-- TODO: Move dynamic_buf to interpreter_Record.
if Dynamic_Buf /= null then
Pool.Deallocate (Dynamic_Buf);
end if;
@ -1066,12 +1064,169 @@ package body Bigint is
end;
end To_String;
procedure From_String (Interp: in out Interpreter_Record;
X: in Object_Pointer;
Radix: in Object_Half_Word;
X: in Object_Character_Array;
Radix: in Object_Radix;
Z: out Object_Pointer) is
begin
null;
end From_String;
end Bigint;
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;
when Ch.Pos.LC_A .. Ch.Pos.LC_Z =>
return Pos - Ch.Pos.LC_A + 10;
when Ch.Pos.UC_A .. Ch.Pos.UC_Z =>
return Pos - Ch.Pos.UC_A + 10;
when others =>
return -1;
end case;
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;
B: Object_Pointer;
DV: Object_Integer;
begin
-- Find the first digit while remembering the sign
Sign := Positive_Sign;
Idx := X'First;
if Idx <= X'Last then
if X(Idx) = Ch.Plus_Sign then
Idx := Idx + 1;
elsif X(Idx) = Ch.Minus_Sign then
Idx := Idx + 1;
Sign := Negative_Sign;
end if;
end if;
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;
end if;
-- Search backward to find the last 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;
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);
exit when W > Object_Word(Object_Integer'Last);
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;
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?
ada.text_io.put_line ("SWITING TO BIGINT" & B.Size'Img & " IDX => " & Idx'Img);
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));
end if;
Idx := Idx + 1;
end loop;
while W > 0 loop
ZI := ZI + 1;
B.Half_Word_Slot(ZI) := Get_Low(W);
W := Object_Word(Get_High(W));
end loop;
B.Sign := Sign;
Z := 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;
begin
Len := 1;
W := Object_Word(Radix);
loop
V := W * Object_Word(Radix);
if V = W then
Len := Len + 1;
W := V;
exit;
elsif V < W then
exit;
end if;
Len := Len + 1;
W := V;
end loop;
return (Low => Get_Low(W), High => Get_High(W), Length => Len);
end Get_Block_Divisor;
procedure Initialize is
begin
-- Initialize block divisors table
if not Block_Divisors_Initialized then
for Radix in Object_Radix'Range loop
Block_Divisors(Radix) := Get_Block_Divisor(Radix);
end loop;
Block_Divisors_Initialized := Standard.True;
end if;
end Initialize;
begin
Initialize;
end Bigint;

36
lib/h2-scheme.adb
View File

@ -403,13 +403,23 @@ package body H2.Scheme is
V := V * 10 + Object_Character'Pos(Source(I)) - Object_Character'Pos(Ch.Zero);
end loop;
if Negative then
if Negative then
V := -V;
end if;
return Integer_To_Pointer(V);
end String_To_Integer_Pointer;
-- TODO: remove this function or improve it to handle conversion properly.
function String_To_Object_Character_Array (Source: in Standard.String) return Object_Character_Array is
Result: Object_Character_Array (1 .. Source'Length);
begin
for I in Result'Range loop
Result(I) := Object_Character'Val(Standard.Character'Pos(Source(Source'First + Standard.Natural(I) - 1)));
end loop;
return Result;
end;
-----------------------------------------------------------------------------
-- MORE CONVERSIONS
-----------------------------------------------------------------------------
@ -2088,6 +2098,10 @@ end if;
Interp.Else_Symbol := Make_Symbol(Interp.Self, Label_Else);
end Make_Common_Symbol_Objects;
begin
-- Initialize child packages in case library-level initialization
-- has been skipped for various reasons.
Bigint.Initialize;
declare
Aliased_Interp: aliased Interpreter_Record;
for Aliased_Interp'Address use Interp'Address;
@ -2681,18 +2695,18 @@ A := Make_Bigint(Interp.Self, Value => Object_Integer'Last - 16#FFFF#);
B := Make_Bigint(Interp.Self, Value => Object_Integer'Last);
B.sign := Negative_Sign;
A := Make_Bigint(Interp.Self, Size => 10);
A.Half_Word_Slot(10) := Object_Half_Word'Last;
A := Make_Bigint(Interp.Self, Size => 30);
A.Half_Word_Slot(30) := Object_Half_Word'Last;
Bigint.Multiply(Interp, A, integer_to_pointer(2), A);
Bigint.Add(Interp, A, A, A);
B := Make_Bigint(Interp.Self, Size => 4);
B.Half_Word_Slot(4) := Object_Half_Word'Last / 2;
Bigint.Subtract(Interp, B, integer_to_pointer(1), B);
Bigint.Subtract(Interp, integer_to_pointer(1), B, B);
--A := Bigint.Divide(Interp, A, integer_to_pointer(0));
print (interp, A);
print (interp, B);
ada.text_io.put ("A => "); print (interp, A);
ada.text_io.put ("B => "); print (interp, B);
declare
q, r: object_Pointer;
begin
@ -2702,13 +2716,21 @@ begin
ada.text_io.put ("Q => "); print (interp, Q);
ada.text_io.put ("R => "); print (interp, R);
bigint.to_string (interp, r, 16,r);
bigint.to_string (interp, Q, 16,r);
--bigint.to_string (interp, integer_to_pointer(-2), 10, r);
print (interp, r);
--bigint.to_string (interp, r, 10, r);
end;
Pop_tops (Interp, 2);
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);
print (interp, q);
end;
Ada.Text_IO.Put_LINE ("=== BYE ===");
Pop_Tops (Interp, 1);

15
lib/h2-scheme.ads
View File

@ -89,7 +89,10 @@ package H2.Scheme is
type Object_Record;
type Object_Pointer is access all Object_Record;
for Object_Pointer'Size use Object_Pointer_Bits;
type Object_Bit is mod 2 ** 1;
--for Object_Bit'Size use 1;
-- Object_Word is a numeric type as large as Object_Poinetr;
type Object_Word is mod 2 ** Object_Pointer_Bits;
for Object_Word'Size use Object_Pointer_Bits;
@ -596,7 +599,8 @@ private
end Token;
package Bigint is
subtype Object_Radix is Object_Word range 2 .. 36;
function Get_Low (W: Object_Word) return Object_Half_Word;
@ -633,6 +637,13 @@ private
X: in Object_Pointer;
Radix: in Object_Radix;
Z: out Object_Pointer);
procedure From_String (Interp: in out Interpreter_Record;
X: in Object_Character_Array;
Radix: in Object_Radix;
Z: out Object_Pointer);
procedure Initialize;
end Bigint;
end H2.Scheme;

12
lib/h2-utf8.adb
View File

@ -1,5 +1,3 @@
with ada.text_io;
package body H2.Utf8 is
type Uint8 is mod 2 ** 8;
@ -64,7 +62,7 @@ package body H2.Utf8 is
function Unicode_To_Utf8 (US: in Unicode_String) return Utf8_String is
-- this function has high stack pressur if the input string is too long
-- this function has high stack pressure if the input string is too long
-- TODO: create a procedure to overcome this problem.
Tmp: System_Size;
begin
@ -93,14 +91,14 @@ package body H2.Utf8 is
end;
end Unicode_To_Utf8;
procedure Utf8_To_Unicode (Utf8: in Utf8_String;
UC: out Unicode_Character) is
procedure Utf8_To_Unicode (Utf8: in Utf8_String;
UC: out Unicode_Character) is
begin
null;
end Utf8_To_Unicode;
procedure Utf8_To_Unicode (Utf8: in Utf8_String;
US: in out Unicode_String) is
procedure Utf8_To_Unicode (Utf8: in Utf8_String;
US: in out Unicode_String) is
begin
null;
end Utf8_To_Unicode;

1
lib/h2-utf8.ads
View File

@ -2,6 +2,7 @@ generic
type Utf8_Character_Type is (<>);
type Unicode_Character_Type is (<>);
package H2.Utf8 is
pragma Preelaborate (Utf8);
Invalid_Unicode_Character: exception;

1
lib/h2.ads
View File

@ -2,6 +2,7 @@ with System;
with System.Storage_Pools;
package H2 is
pragma Preelaborate (H2);
System_Word_Bits: constant := System.Word_Size;
System_Word_Bytes: constant := System_Word_Bits / System.Storage_Unit;