From 64d69c36e5cf631ba06f23dafe99133b49a62237 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Sun, 9 Mar 2014 18:01:38 +0000 Subject: [PATCH] added the incomplete string-to-bigint conversion procedure --- cmd/scheme.adb | 5 + lib/ascii.awk | 1 + lib/h2-ascii.ads | 2 + lib/h2-pool.ads | 1 + lib/h2-scheme-bigint.adb | 271 ++++++++++++++++++++++++++++++--------- lib/h2-scheme.adb | 36 +++++- lib/h2-scheme.ads | 15 ++- lib/h2-utf8.adb | 12 +- lib/h2-utf8.ads | 1 + lib/h2.ads | 1 + 10 files changed, 271 insertions(+), 74 deletions(-) diff --git a/cmd/scheme.adb b/cmd/scheme.adb index 739edee..55e04e9 100644 --- a/cmd/scheme.adb +++ b/cmd/scheme.adb @@ -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); diff --git a/lib/ascii.awk b/lib/ascii.awk index 3155ca6..837fe9d 100644 --- a/lib/ascii.awk +++ b/lib/ascii.awk @@ -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"); } diff --git a/lib/h2-ascii.ads b/lib/h2-ascii.ads index f7e0c8c..107e8d4 100644 --- a/lib/h2-ascii.ads +++ b/lib/h2-ascii.ads @@ -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; diff --git a/lib/h2-pool.ads b/lib/h2-pool.ads index 91df370..dcfacaf 100644 --- a/lib/h2-pool.ads +++ b/lib/h2-pool.ads @@ -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; diff --git a/lib/h2-scheme-bigint.adb b/lib/h2-scheme-bigint.adb index 41e6eac..c35300c 100644 --- a/lib/h2-scheme-bigint.adb +++ b/lib/h2-scheme-bigint.adb @@ -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; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 805484c..e46841b 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -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); diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 6a57cee..0f28750 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -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; diff --git a/lib/h2-utf8.adb b/lib/h2-utf8.adb index b07d4a0..7419626 100644 --- a/lib/h2-utf8.adb +++ b/lib/h2-utf8.adb @@ -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; diff --git a/lib/h2-utf8.ads b/lib/h2-utf8.ads index afc1ac3..084d674 100644 --- a/lib/h2-utf8.ads +++ b/lib/h2-utf8.ads @@ -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; diff --git a/lib/h2.ads b/lib/h2.ads index eff3fde..a76b6bb 100644 --- a/lib/h2.ads +++ b/lib/h2.ads @@ -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;