URL
https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me
[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [uintp.adb] - Rev 281
Compare with Previous | Blame | View Log
------------------------------------------------------------------------------ -- -- -- GNAT COMPILER COMPONENTS -- -- -- -- U I N T P -- -- -- -- B o d y -- -- -- -- Copyright (C) 1992-2009, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- -- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. -- -- -- -- As a special exception under Section 7 of GPL version 3, you are granted -- -- additional permissions described in the GCC Runtime Library Exception, -- -- version 3.1, as published by the Free Software Foundation. -- -- -- -- You should have received a copy of the GNU General Public License and -- -- a copy of the GCC Runtime Library Exception along with this program; -- -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see -- -- <http://www.gnu.org/licenses/>. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- -- -- ------------------------------------------------------------------------------ with Output; use Output; with Tree_IO; use Tree_IO; with GNAT.HTable; use GNAT.HTable; package body Uintp is ------------------------ -- Local Declarations -- ------------------------ Uint_Int_First : Uint := Uint_0; -- Uint value containing Int'First value, set by Initialize. The initial -- value of Uint_0 is used for an assertion check that ensures that this -- value is not used before it is initialized. This value is used in the -- UI_Is_In_Int_Range predicate, and it is right that this is a host value, -- since the issue is host representation of integer values. Uint_Int_Last : Uint; -- Uint value containing Int'Last value set by Initialize UI_Power_2 : array (Int range 0 .. 64) of Uint; -- This table is used to memoize exponentiations by powers of 2. The Nth -- entry, if set, contains the Uint value 2 ** N. Initially UI_Power_2_Set -- is zero and only the 0'th entry is set, the invariant being that all -- entries in the range 0 .. UI_Power_2_Set are initialized. UI_Power_2_Set : Nat; -- Number of entries set in UI_Power_2; UI_Power_10 : array (Int range 0 .. 64) of Uint; -- This table is used to memoize exponentiations by powers of 10 in the -- same manner as described above for UI_Power_2. UI_Power_10_Set : Nat; -- Number of entries set in UI_Power_10; Uints_Min : Uint; Udigits_Min : Int; -- These values are used to make sure that the mark/release mechanism does -- not destroy values saved in the U_Power tables or in the hash table used -- by UI_From_Int. Whenever an entry is made in either of these tables, -- Uints_Min and Udigits_Min are updated to protect the entry, and Release -- never cuts back beyond these minimum values. Int_0 : constant Int := 0; Int_1 : constant Int := 1; Int_2 : constant Int := 2; -- These values are used in some cases where the use of numeric literals -- would cause ambiguities (integer vs Uint). ---------------------------- -- UI_From_Int Hash Table -- ---------------------------- -- UI_From_Int uses a hash table to avoid duplicating entries and wasting -- storage. This is particularly important for complex cases of back -- annotation. subtype Hnum is Nat range 0 .. 1022; function Hash_Num (F : Int) return Hnum; -- Hashing function package UI_Ints is new Simple_HTable ( Header_Num => Hnum, Element => Uint, No_Element => No_Uint, Key => Int, Hash => Hash_Num, Equal => "="); ----------------------- -- Local Subprograms -- ----------------------- function Direct (U : Uint) return Boolean; pragma Inline (Direct); -- Returns True if U is represented directly function Direct_Val (U : Uint) return Int; -- U is a Uint for is represented directly. The returned result is the -- value represented. function GCD (Jin, Kin : Int) return Int; -- Compute GCD of two integers. Assumes that Jin >= Kin >= 0 procedure Image_Out (Input : Uint; To_Buffer : Boolean; Format : UI_Format); -- Common processing for UI_Image and UI_Write, To_Buffer is set True for -- UI_Image, and false for UI_Write, and Format is copied from the Format -- parameter to UI_Image or UI_Write. procedure Init_Operand (UI : Uint; Vec : out UI_Vector); pragma Inline (Init_Operand); -- This procedure puts the value of UI into the vector in canonical -- multiple precision format. The parameter should be of the correct size -- as determined by a previous call to N_Digits (UI). The first digit of -- Vec contains the sign, all other digits are always non-negative. Note -- that the input may be directly represented, and in this case Vec will -- contain the corresponding one or two digit value. The low bound of Vec -- is always 1. function Least_Sig_Digit (Arg : Uint) return Int; pragma Inline (Least_Sig_Digit); -- Returns the Least Significant Digit of Arg quickly. When the given Uint -- is less than 2**15, the value returned is the input value, in this case -- the result may be negative. It is expected that any use will mask off -- unnecessary bits. This is used for finding Arg mod B where B is a power -- of two. Hence the actual base is irrelevant as long as it is a power of -- two. procedure Most_Sig_2_Digits (Left : Uint; Right : Uint; Left_Hat : out Int; Right_Hat : out Int); -- Returns leading two significant digits from the given pair of Uint's. -- Mathematically: returns Left / (Base ** K) and Right / (Base ** K) where -- K is as small as possible S.T. Right_Hat < Base * Base. It is required -- that Left > Right for the algorithm to work. function N_Digits (Input : Uint) return Int; pragma Inline (N_Digits); -- Returns number of "digits" in a Uint function Sum_Digits (Left : Uint; Sign : Int) return Int; -- If Sign = 1 return the sum of the "digits" of Abs (Left). If the total -- has more then one digit then return Sum_Digits of total. function Sum_Double_Digits (Left : Uint; Sign : Int) return Int; -- Same as above but work in New_Base = Base * Base procedure UI_Div_Rem (Left, Right : Uint; Quotient : out Uint; Remainder : out Uint; Discard_Quotient : Boolean; Discard_Remainder : Boolean); -- Compute Euclidean division of Left by Right, and return Quotient and -- signed Remainder (Left rem Right). -- -- If Discard_Quotient is True, Quotient is left unchanged. -- If Discard_Remainder is True, Remainder is left unchanged. function Vector_To_Uint (In_Vec : UI_Vector; Negative : Boolean) return Uint; -- Functions that calculate values in UI_Vectors, call this function to -- create and return the Uint value. In_Vec contains the multiple precision -- (Base) representation of a non-negative value. Leading zeroes are -- permitted. Negative is set if the desired result is the negative of the -- given value. The result will be either the appropriate directly -- represented value, or a table entry in the proper canonical format is -- created and returned. -- -- Note that Init_Operand puts a signed value in the result vector, but -- Vector_To_Uint is always presented with a non-negative value. The -- processing of signs is something that is done by the caller before -- calling Vector_To_Uint. ------------ -- Direct -- ------------ function Direct (U : Uint) return Boolean is begin return Int (U) <= Int (Uint_Direct_Last); end Direct; ---------------- -- Direct_Val -- ---------------- function Direct_Val (U : Uint) return Int is begin pragma Assert (Direct (U)); return Int (U) - Int (Uint_Direct_Bias); end Direct_Val; --------- -- GCD -- --------- function GCD (Jin, Kin : Int) return Int is J, K, Tmp : Int; begin pragma Assert (Jin >= Kin); pragma Assert (Kin >= Int_0); J := Jin; K := Kin; while K /= Uint_0 loop Tmp := J mod K; J := K; K := Tmp; end loop; return J; end GCD; -------------- -- Hash_Num -- -------------- function Hash_Num (F : Int) return Hnum is begin return Standard."mod" (F, Hnum'Range_Length); end Hash_Num; --------------- -- Image_Out -- --------------- procedure Image_Out (Input : Uint; To_Buffer : Boolean; Format : UI_Format) is Marks : constant Uintp.Save_Mark := Uintp.Mark; Base : Uint; Ainput : Uint; Digs_Output : Natural := 0; -- Counts digits output. In hex mode, but not in decimal mode, we -- put an underline after every four hex digits that are output. Exponent : Natural := 0; -- If the number is too long to fit in the buffer, we switch to an -- approximate output format with an exponent. This variable records -- the exponent value. function Better_In_Hex return Boolean; -- Determines if it is better to generate digits in base 16 (result -- is true) or base 10 (result is false). The choice is purely a -- matter of convenience and aesthetics, so it does not matter which -- value is returned from a correctness point of view. procedure Image_Char (C : Character); -- Internal procedure to output one character procedure Image_Exponent (N : Natural); -- Output non-zero exponent. Note that we only use the exponent form in -- the buffer case, so we know that To_Buffer is true. procedure Image_Uint (U : Uint); -- Internal procedure to output characters of non-negative Uint ------------------- -- Better_In_Hex -- ------------------- function Better_In_Hex return Boolean is T16 : constant Uint := Uint_2 ** Int'(16); A : Uint; begin A := UI_Abs (Input); -- Small values up to 2**16 can always be in decimal if A < T16 then return False; end if; -- Otherwise, see if we are a power of 2 or one less than a power -- of 2. For the moment these are the only cases printed in hex. if A mod Uint_2 = Uint_1 then A := A + Uint_1; end if; loop if A mod T16 /= Uint_0 then return False; else A := A / T16; end if; exit when A < T16; end loop; while A > Uint_2 loop if A mod Uint_2 /= Uint_0 then return False; else A := A / Uint_2; end if; end loop; return True; end Better_In_Hex; ---------------- -- Image_Char -- ---------------- procedure Image_Char (C : Character) is begin if To_Buffer then if UI_Image_Length + 6 > UI_Image_Max then Exponent := Exponent + 1; else UI_Image_Length := UI_Image_Length + 1; UI_Image_Buffer (UI_Image_Length) := C; end if; else Write_Char (C); end if; end Image_Char; -------------------- -- Image_Exponent -- -------------------- procedure Image_Exponent (N : Natural) is begin if N >= 10 then Image_Exponent (N / 10); end if; UI_Image_Length := UI_Image_Length + 1; UI_Image_Buffer (UI_Image_Length) := Character'Val (Character'Pos ('0') + N mod 10); end Image_Exponent; ---------------- -- Image_Uint -- ---------------- procedure Image_Uint (U : Uint) is H : constant array (Int range 0 .. 15) of Character := "0123456789ABCDEF"; begin if U >= Base then Image_Uint (U / Base); end if; if Digs_Output = 4 and then Base = Uint_16 then Image_Char ('_'); Digs_Output := 0; end if; Image_Char (H (UI_To_Int (U rem Base))); Digs_Output := Digs_Output + 1; end Image_Uint; -- Start of processing for Image_Out begin if Input = No_Uint then Image_Char ('?'); return; end if; UI_Image_Length := 0; if Input < Uint_0 then Image_Char ('-'); Ainput := -Input; else Ainput := Input; end if; if Format = Hex or else (Format = Auto and then Better_In_Hex) then Base := Uint_16; Image_Char ('1'); Image_Char ('6'); Image_Char ('#'); Image_Uint (Ainput); Image_Char ('#'); else Base := Uint_10; Image_Uint (Ainput); end if; if Exponent /= 0 then UI_Image_Length := UI_Image_Length + 1; UI_Image_Buffer (UI_Image_Length) := 'E'; Image_Exponent (Exponent); end if; Uintp.Release (Marks); end Image_Out; ------------------- -- Init_Operand -- ------------------- procedure Init_Operand (UI : Uint; Vec : out UI_Vector) is Loc : Int; pragma Assert (Vec'First = Int'(1)); begin if Direct (UI) then Vec (1) := Direct_Val (UI); if Vec (1) >= Base then Vec (2) := Vec (1) rem Base; Vec (1) := Vec (1) / Base; end if; else Loc := Uints.Table (UI).Loc; for J in 1 .. Uints.Table (UI).Length loop Vec (J) := Udigits.Table (Loc + J - 1); end loop; end if; end Init_Operand; ---------------- -- Initialize -- ---------------- procedure Initialize is begin Uints.Init; Udigits.Init; Uint_Int_First := UI_From_Int (Int'First); Uint_Int_Last := UI_From_Int (Int'Last); UI_Power_2 (0) := Uint_1; UI_Power_2_Set := 0; UI_Power_10 (0) := Uint_1; UI_Power_10_Set := 0; Uints_Min := Uints.Last; Udigits_Min := Udigits.Last; UI_Ints.Reset; end Initialize; --------------------- -- Least_Sig_Digit -- --------------------- function Least_Sig_Digit (Arg : Uint) return Int is V : Int; begin if Direct (Arg) then V := Direct_Val (Arg); if V >= Base then V := V mod Base; end if; -- Note that this result may be negative return V; else return Udigits.Table (Uints.Table (Arg).Loc + Uints.Table (Arg).Length - 1); end if; end Least_Sig_Digit; ---------- -- Mark -- ---------- function Mark return Save_Mark is begin return (Save_Uint => Uints.Last, Save_Udigit => Udigits.Last); end Mark; ----------------------- -- Most_Sig_2_Digits -- ----------------------- procedure Most_Sig_2_Digits (Left : Uint; Right : Uint; Left_Hat : out Int; Right_Hat : out Int) is begin pragma Assert (Left >= Right); if Direct (Left) then Left_Hat := Direct_Val (Left); Right_Hat := Direct_Val (Right); return; else declare L1 : constant Int := Udigits.Table (Uints.Table (Left).Loc); L2 : constant Int := Udigits.Table (Uints.Table (Left).Loc + 1); begin -- It is not so clear what to return when Arg is negative??? Left_Hat := abs (L1) * Base + L2; end; end if; declare Length_L : constant Int := Uints.Table (Left).Length; Length_R : Int; R1 : Int; R2 : Int; T : Int; begin if Direct (Right) then T := Direct_Val (Left); R1 := abs (T / Base); R2 := T rem Base; Length_R := 2; else R1 := abs (Udigits.Table (Uints.Table (Right).Loc)); R2 := Udigits.Table (Uints.Table (Right).Loc + 1); Length_R := Uints.Table (Right).Length; end if; if Length_L = Length_R then Right_Hat := R1 * Base + R2; elsif Length_L = Length_R + Int_1 then Right_Hat := R1; else Right_Hat := 0; end if; end; end Most_Sig_2_Digits; --------------- -- N_Digits -- --------------- -- Note: N_Digits returns 1 for No_Uint function N_Digits (Input : Uint) return Int is begin if Direct (Input) then if Direct_Val (Input) >= Base then return 2; else return 1; end if; else return Uints.Table (Input).Length; end if; end N_Digits; -------------- -- Num_Bits -- -------------- function Num_Bits (Input : Uint) return Nat is Bits : Nat; Num : Nat; begin -- Largest negative number has to be handled specially, since it is in -- Int_Range, but we cannot take the absolute value. if Input = Uint_Int_First then return Int'Size; -- For any other number in Int_Range, get absolute value of number elsif UI_Is_In_Int_Range (Input) then Num := abs (UI_To_Int (Input)); Bits := 0; -- If not in Int_Range then initialize bit count for all low order -- words, and set number to high order digit. else Bits := Base_Bits * (Uints.Table (Input).Length - 1); Num := abs (Udigits.Table (Uints.Table (Input).Loc)); end if; -- Increase bit count for remaining value in Num while Types.">" (Num, 0) loop Num := Num / 2; Bits := Bits + 1; end loop; return Bits; end Num_Bits; --------- -- pid -- --------- procedure pid (Input : Uint) is begin UI_Write (Input, Decimal); Write_Eol; end pid; --------- -- pih -- --------- procedure pih (Input : Uint) is begin UI_Write (Input, Hex); Write_Eol; end pih; ------------- -- Release -- ------------- procedure Release (M : Save_Mark) is begin Uints.Set_Last (Uint'Max (M.Save_Uint, Uints_Min)); Udigits.Set_Last (Int'Max (M.Save_Udigit, Udigits_Min)); end Release; ---------------------- -- Release_And_Save -- ---------------------- procedure Release_And_Save (M : Save_Mark; UI : in out Uint) is begin if Direct (UI) then Release (M); else declare UE_Len : constant Pos := Uints.Table (UI).Length; UE_Loc : constant Int := Uints.Table (UI).Loc; UD : constant Udigits.Table_Type (1 .. UE_Len) := Udigits.Table (UE_Loc .. UE_Loc + UE_Len - 1); begin Release (M); Uints.Append ((Length => UE_Len, Loc => Udigits.Last + 1)); UI := Uints.Last; for J in 1 .. UE_Len loop Udigits.Append (UD (J)); end loop; end; end if; end Release_And_Save; procedure Release_And_Save (M : Save_Mark; UI1, UI2 : in out Uint) is begin if Direct (UI1) then Release_And_Save (M, UI2); elsif Direct (UI2) then Release_And_Save (M, UI1); else declare UE1_Len : constant Pos := Uints.Table (UI1).Length; UE1_Loc : constant Int := Uints.Table (UI1).Loc; UD1 : constant Udigits.Table_Type (1 .. UE1_Len) := Udigits.Table (UE1_Loc .. UE1_Loc + UE1_Len - 1); UE2_Len : constant Pos := Uints.Table (UI2).Length; UE2_Loc : constant Int := Uints.Table (UI2).Loc; UD2 : constant Udigits.Table_Type (1 .. UE2_Len) := Udigits.Table (UE2_Loc .. UE2_Loc + UE2_Len - 1); begin Release (M); Uints.Append ((Length => UE1_Len, Loc => Udigits.Last + 1)); UI1 := Uints.Last; for J in 1 .. UE1_Len loop Udigits.Append (UD1 (J)); end loop; Uints.Append ((Length => UE2_Len, Loc => Udigits.Last + 1)); UI2 := Uints.Last; for J in 1 .. UE2_Len loop Udigits.Append (UD2 (J)); end loop; end; end if; end Release_And_Save; ---------------- -- Sum_Digits -- ---------------- -- This is done in one pass -- Mathematically: assume base congruent to 1 and compute an equivalent -- integer to Left. -- If Sign = -1 return the alternating sum of the "digits" -- D1 - D2 + D3 - D4 + D5 ... -- (where D1 is Least Significant Digit) -- Mathematically: assume base congruent to -1 and compute an equivalent -- integer to Left. -- This is used in Rem and Base is assumed to be 2 ** 15 -- Note: The next two functions are very similar, any style changes made -- to one should be reflected in both. These would be simpler if we -- worked base 2 ** 32. function Sum_Digits (Left : Uint; Sign : Int) return Int is begin pragma Assert (Sign = Int_1 or else Sign = Int (-1)); -- First try simple case; if Direct (Left) then declare Tmp_Int : Int := Direct_Val (Left); begin if Tmp_Int >= Base then Tmp_Int := (Tmp_Int / Base) + Sign * (Tmp_Int rem Base); -- Now Tmp_Int is in [-(Base - 1) .. 2 * (Base - 1)] if Tmp_Int >= Base then -- Sign must be 1 Tmp_Int := (Tmp_Int / Base) + 1; end if; -- Now Tmp_Int is in [-(Base - 1) .. (Base - 1)] end if; return Tmp_Int; end; -- Otherwise full circuit is needed else declare L_Length : constant Int := N_Digits (Left); L_Vec : UI_Vector (1 .. L_Length); Tmp_Int : Int; Carry : Int; Alt : Int; begin Init_Operand (Left, L_Vec); L_Vec (1) := abs L_Vec (1); Tmp_Int := 0; Carry := 0; Alt := 1; for J in reverse 1 .. L_Length loop Tmp_Int := Tmp_Int + Alt * (L_Vec (J) + Carry); -- Tmp_Int is now between [-2 * Base + 1 .. 2 * Base - 1], -- since old Tmp_Int is between [-(Base - 1) .. Base - 1] -- and L_Vec is in [0 .. Base - 1] and Carry in [-1 .. 1] if Tmp_Int >= Base then Tmp_Int := Tmp_Int - Base; Carry := 1; elsif Tmp_Int <= -Base then Tmp_Int := Tmp_Int + Base; Carry := -1; else Carry := 0; end if; -- Tmp_Int is now between [-Base + 1 .. Base - 1] Alt := Alt * Sign; end loop; Tmp_Int := Tmp_Int + Alt * Carry; -- Tmp_Int is now between [-Base .. Base] if Tmp_Int >= Base then Tmp_Int := Tmp_Int - Base + Alt * Sign * 1; elsif Tmp_Int <= -Base then Tmp_Int := Tmp_Int + Base + Alt * Sign * (-1); end if; -- Now Tmp_Int is in [-(Base - 1) .. (Base - 1)] return Tmp_Int; end; end if; end Sum_Digits; ----------------------- -- Sum_Double_Digits -- ----------------------- -- Note: This is used in Rem, Base is assumed to be 2 ** 15 function Sum_Double_Digits (Left : Uint; Sign : Int) return Int is begin -- First try simple case; pragma Assert (Sign = Int_1 or else Sign = Int (-1)); if Direct (Left) then return Direct_Val (Left); -- Otherwise full circuit is needed else declare L_Length : constant Int := N_Digits (Left); L_Vec : UI_Vector (1 .. L_Length); Most_Sig_Int : Int; Least_Sig_Int : Int; Carry : Int; J : Int; Alt : Int; begin Init_Operand (Left, L_Vec); L_Vec (1) := abs L_Vec (1); Most_Sig_Int := 0; Least_Sig_Int := 0; Carry := 0; Alt := 1; J := L_Length; while J > Int_1 loop Least_Sig_Int := Least_Sig_Int + Alt * (L_Vec (J) + Carry); -- Least is in [-2 Base + 1 .. 2 * Base - 1] -- Since L_Vec in [0 .. Base - 1] and Carry in [-1 .. 1] -- and old Least in [-Base + 1 .. Base - 1] if Least_Sig_Int >= Base then Least_Sig_Int := Least_Sig_Int - Base; Carry := 1; elsif Least_Sig_Int <= -Base then Least_Sig_Int := Least_Sig_Int + Base; Carry := -1; else Carry := 0; end if; -- Least is now in [-Base + 1 .. Base - 1] Most_Sig_Int := Most_Sig_Int + Alt * (L_Vec (J - 1) + Carry); -- Most is in [-2 Base + 1 .. 2 * Base - 1] -- Since L_Vec in [0 .. Base - 1] and Carry in [-1 .. 1] -- and old Most in [-Base + 1 .. Base - 1] if Most_Sig_Int >= Base then Most_Sig_Int := Most_Sig_Int - Base; Carry := 1; elsif Most_Sig_Int <= -Base then Most_Sig_Int := Most_Sig_Int + Base; Carry := -1; else Carry := 0; end if; -- Most is now in [-Base + 1 .. Base - 1] J := J - 2; Alt := Alt * Sign; end loop; if J = Int_1 then Least_Sig_Int := Least_Sig_Int + Alt * (L_Vec (J) + Carry); else Least_Sig_Int := Least_Sig_Int + Alt * Carry; end if; if Least_Sig_Int >= Base then Least_Sig_Int := Least_Sig_Int - Base; Most_Sig_Int := Most_Sig_Int + Alt * 1; elsif Least_Sig_Int <= -Base then Least_Sig_Int := Least_Sig_Int + Base; Most_Sig_Int := Most_Sig_Int + Alt * (-1); end if; if Most_Sig_Int >= Base then Most_Sig_Int := Most_Sig_Int - Base; Alt := Alt * Sign; Least_Sig_Int := Least_Sig_Int + Alt * 1; -- cannot overflow again elsif Most_Sig_Int <= -Base then Most_Sig_Int := Most_Sig_Int + Base; Alt := Alt * Sign; Least_Sig_Int := Least_Sig_Int + Alt * (-1); -- cannot overflow again. end if; return Most_Sig_Int * Base + Least_Sig_Int; end; end if; end Sum_Double_Digits; --------------- -- Tree_Read -- --------------- procedure Tree_Read is begin Uints.Tree_Read; Udigits.Tree_Read; Tree_Read_Int (Int (Uint_Int_First)); Tree_Read_Int (Int (Uint_Int_Last)); Tree_Read_Int (UI_Power_2_Set); Tree_Read_Int (UI_Power_10_Set); Tree_Read_Int (Int (Uints_Min)); Tree_Read_Int (Udigits_Min); for J in 0 .. UI_Power_2_Set loop Tree_Read_Int (Int (UI_Power_2 (J))); end loop; for J in 0 .. UI_Power_10_Set loop Tree_Read_Int (Int (UI_Power_10 (J))); end loop; end Tree_Read; ---------------- -- Tree_Write -- ---------------- procedure Tree_Write is begin Uints.Tree_Write; Udigits.Tree_Write; Tree_Write_Int (Int (Uint_Int_First)); Tree_Write_Int (Int (Uint_Int_Last)); Tree_Write_Int (UI_Power_2_Set); Tree_Write_Int (UI_Power_10_Set); Tree_Write_Int (Int (Uints_Min)); Tree_Write_Int (Udigits_Min); for J in 0 .. UI_Power_2_Set loop Tree_Write_Int (Int (UI_Power_2 (J))); end loop; for J in 0 .. UI_Power_10_Set loop Tree_Write_Int (Int (UI_Power_10 (J))); end loop; end Tree_Write; ------------- -- UI_Abs -- ------------- function UI_Abs (Right : Uint) return Uint is begin if Right < Uint_0 then return -Right; else return Right; end if; end UI_Abs; ------------- -- UI_Add -- ------------- function UI_Add (Left : Int; Right : Uint) return Uint is begin return UI_Add (UI_From_Int (Left), Right); end UI_Add; function UI_Add (Left : Uint; Right : Int) return Uint is begin return UI_Add (Left, UI_From_Int (Right)); end UI_Add; function UI_Add (Left : Uint; Right : Uint) return Uint is begin -- Simple cases of direct operands and addition of zero if Direct (Left) then if Direct (Right) then return UI_From_Int (Direct_Val (Left) + Direct_Val (Right)); elsif Int (Left) = Int (Uint_0) then return Right; end if; elsif Direct (Right) and then Int (Right) = Int (Uint_0) then return Left; end if; -- Otherwise full circuit is needed declare L_Length : constant Int := N_Digits (Left); R_Length : constant Int := N_Digits (Right); L_Vec : UI_Vector (1 .. L_Length); R_Vec : UI_Vector (1 .. R_Length); Sum_Length : Int; Tmp_Int : Int; Carry : Int; Borrow : Int; X_Bigger : Boolean := False; Y_Bigger : Boolean := False; Result_Neg : Boolean := False; begin Init_Operand (Left, L_Vec); Init_Operand (Right, R_Vec); -- At least one of the two operands is in multi-digit form. -- Calculate the number of digits sufficient to hold result. if L_Length > R_Length then Sum_Length := L_Length + 1; X_Bigger := True; else Sum_Length := R_Length + 1; if R_Length > L_Length then Y_Bigger := True; end if; end if; -- Make copies of the absolute values of L_Vec and R_Vec into X and Y -- both with lengths equal to the maximum possibly needed. This makes -- looping over the digits much simpler. declare X : UI_Vector (1 .. Sum_Length); Y : UI_Vector (1 .. Sum_Length); Tmp_UI : UI_Vector (1 .. Sum_Length); begin for J in 1 .. Sum_Length - L_Length loop X (J) := 0; end loop; X (Sum_Length - L_Length + 1) := abs L_Vec (1); for J in 2 .. L_Length loop X (J + (Sum_Length - L_Length)) := L_Vec (J); end loop; for J in 1 .. Sum_Length - R_Length loop Y (J) := 0; end loop; Y (Sum_Length - R_Length + 1) := abs R_Vec (1); for J in 2 .. R_Length loop Y (J + (Sum_Length - R_Length)) := R_Vec (J); end loop; if (L_Vec (1) < Int_0) = (R_Vec (1) < Int_0) then -- Same sign so just add Carry := 0; for J in reverse 1 .. Sum_Length loop Tmp_Int := X (J) + Y (J) + Carry; if Tmp_Int >= Base then Tmp_Int := Tmp_Int - Base; Carry := 1; else Carry := 0; end if; X (J) := Tmp_Int; end loop; return Vector_To_Uint (X, L_Vec (1) < Int_0); else -- Find which one has bigger magnitude if not (X_Bigger or Y_Bigger) then for J in L_Vec'Range loop if abs L_Vec (J) > abs R_Vec (J) then X_Bigger := True; exit; elsif abs R_Vec (J) > abs L_Vec (J) then Y_Bigger := True; exit; end if; end loop; end if; -- If they have identical magnitude, just return 0, else swap -- if necessary so that X had the bigger magnitude. Determine -- if result is negative at this time. Result_Neg := False; if not (X_Bigger or Y_Bigger) then return Uint_0; elsif Y_Bigger then if R_Vec (1) < Int_0 then Result_Neg := True; end if; Tmp_UI := X; X := Y; Y := Tmp_UI; else if L_Vec (1) < Int_0 then Result_Neg := True; end if; end if; -- Subtract Y from the bigger X Borrow := 0; for J in reverse 1 .. Sum_Length loop Tmp_Int := X (J) - Y (J) + Borrow; if Tmp_Int < Int_0 then Tmp_Int := Tmp_Int + Base; Borrow := -1; else Borrow := 0; end if; X (J) := Tmp_Int; end loop; return Vector_To_Uint (X, Result_Neg); end if; end; end; end UI_Add; -------------------------- -- UI_Decimal_Digits_Hi -- -------------------------- function UI_Decimal_Digits_Hi (U : Uint) return Nat is begin -- The maximum value of a "digit" is 32767, which is 5 decimal digits, -- so an N_Digit number could take up to 5 times this number of digits. -- This is certainly too high for large numbers but it is not worth -- worrying about. return 5 * N_Digits (U); end UI_Decimal_Digits_Hi; -------------------------- -- UI_Decimal_Digits_Lo -- -------------------------- function UI_Decimal_Digits_Lo (U : Uint) return Nat is begin -- The maximum value of a "digit" is 32767, which is more than four -- decimal digits, but not a full five digits. The easily computed -- minimum number of decimal digits is thus 1 + 4 * the number of -- digits. This is certainly too low for large numbers but it is not -- worth worrying about. return 1 + 4 * (N_Digits (U) - 1); end UI_Decimal_Digits_Lo; ------------ -- UI_Div -- ------------ function UI_Div (Left : Int; Right : Uint) return Uint is begin return UI_Div (UI_From_Int (Left), Right); end UI_Div; function UI_Div (Left : Uint; Right : Int) return Uint is begin return UI_Div (Left, UI_From_Int (Right)); end UI_Div; function UI_Div (Left, Right : Uint) return Uint is Quotient : Uint; Remainder : Uint; pragma Warnings (Off, Remainder); begin UI_Div_Rem (Left, Right, Quotient, Remainder, Discard_Quotient => False, Discard_Remainder => True); return Quotient; end UI_Div; ---------------- -- UI_Div_Rem -- ---------------- procedure UI_Div_Rem (Left, Right : Uint; Quotient : out Uint; Remainder : out Uint; Discard_Quotient : Boolean; Discard_Remainder : Boolean) is pragma Warnings (Off, Quotient); pragma Warnings (Off, Remainder); begin pragma Assert (Right /= Uint_0); -- Cases where both operands are represented directly if Direct (Left) and then Direct (Right) then declare DV_Left : constant Int := Direct_Val (Left); DV_Right : constant Int := Direct_Val (Right); begin if not Discard_Quotient then Quotient := UI_From_Int (DV_Left / DV_Right); end if; if not Discard_Remainder then Remainder := UI_From_Int (DV_Left rem DV_Right); end if; return; end; end if; declare L_Length : constant Int := N_Digits (Left); R_Length : constant Int := N_Digits (Right); Q_Length : constant Int := L_Length - R_Length + 1; L_Vec : UI_Vector (1 .. L_Length); R_Vec : UI_Vector (1 .. R_Length); D : Int; Remainder_I : Int; Tmp_Divisor : Int; Carry : Int; Tmp_Int : Int; Tmp_Dig : Int; procedure UI_Div_Vector (L_Vec : UI_Vector; R_Int : Int; Quotient : out UI_Vector; Remainder : out Int); pragma Inline (UI_Div_Vector); -- Specialised variant for case where the divisor is a single digit procedure UI_Div_Vector (L_Vec : UI_Vector; R_Int : Int; Quotient : out UI_Vector; Remainder : out Int) is Tmp_Int : Int; begin Remainder := 0; for J in L_Vec'Range loop Tmp_Int := Remainder * Base + abs L_Vec (J); Quotient (Quotient'First + J - L_Vec'First) := Tmp_Int / R_Int; Remainder := Tmp_Int rem R_Int; end loop; if L_Vec (L_Vec'First) < Int_0 then Remainder := -Remainder; end if; end UI_Div_Vector; -- Start of processing for UI_Div_Rem begin -- Result is zero if left operand is shorter than right if L_Length < R_Length then if not Discard_Quotient then Quotient := Uint_0; end if; if not Discard_Remainder then Remainder := Left; end if; return; end if; Init_Operand (Left, L_Vec); Init_Operand (Right, R_Vec); -- Case of right operand is single digit. Here we can simply divide -- each digit of the left operand by the divisor, from most to least -- significant, carrying the remainder to the next digit (just like -- ordinary long division by hand). if R_Length = Int_1 then Tmp_Divisor := abs R_Vec (1); declare Quotient_V : UI_Vector (1 .. L_Length); begin UI_Div_Vector (L_Vec, Tmp_Divisor, Quotient_V, Remainder_I); if not Discard_Quotient then Quotient := Vector_To_Uint (Quotient_V, (L_Vec (1) < Int_0 xor R_Vec (1) < Int_0)); end if; if not Discard_Remainder then Remainder := UI_From_Int (Remainder_I); end if; return; end; end if; -- The possible simple cases have been exhausted. Now turn to the -- algorithm D from the section of Knuth mentioned at the top of -- this package. Algorithm_D : declare Dividend : UI_Vector (1 .. L_Length + 1); Divisor : UI_Vector (1 .. R_Length); Quotient_V : UI_Vector (1 .. Q_Length); Divisor_Dig1 : Int; Divisor_Dig2 : Int; Q_Guess : Int; begin -- [ NORMALIZE ] (step D1 in the algorithm). First calculate the -- scale d, and then multiply Left and Right (u and v in the book) -- by d to get the dividend and divisor to work with. D := Base / (abs R_Vec (1) + 1); Dividend (1) := 0; Dividend (2) := abs L_Vec (1); for J in 3 .. L_Length + Int_1 loop Dividend (J) := L_Vec (J - 1); end loop; Divisor (1) := abs R_Vec (1); for J in Int_2 .. R_Length loop Divisor (J) := R_Vec (J); end loop; if D > Int_1 then -- Multiply Dividend by D Carry := 0; for J in reverse Dividend'Range loop Tmp_Int := Dividend (J) * D + Carry; Dividend (J) := Tmp_Int rem Base; Carry := Tmp_Int / Base; end loop; -- Multiply Divisor by d Carry := 0; for J in reverse Divisor'Range loop Tmp_Int := Divisor (J) * D + Carry; Divisor (J) := Tmp_Int rem Base; Carry := Tmp_Int / Base; end loop; end if; -- Main loop of long division algorithm Divisor_Dig1 := Divisor (1); Divisor_Dig2 := Divisor (2); for J in Quotient_V'Range loop -- [ CALCULATE Q (hat) ] (step D3 in the algorithm) Tmp_Int := Dividend (J) * Base + Dividend (J + 1); -- Initial guess if Dividend (J) = Divisor_Dig1 then Q_Guess := Base - 1; else Q_Guess := Tmp_Int / Divisor_Dig1; end if; -- Refine the guess while Divisor_Dig2 * Q_Guess > (Tmp_Int - Q_Guess * Divisor_Dig1) * Base + Dividend (J + 2) loop Q_Guess := Q_Guess - 1; end loop; -- [ MULTIPLY & SUBTRACT ] (step D4). Q_Guess * Divisor is -- subtracted from the remaining dividend. Carry := 0; for K in reverse Divisor'Range loop Tmp_Int := Dividend (J + K) - Q_Guess * Divisor (K) + Carry; Tmp_Dig := Tmp_Int rem Base; Carry := Tmp_Int / Base; if Tmp_Dig < Int_0 then Tmp_Dig := Tmp_Dig + Base; Carry := Carry - 1; end if; Dividend (J + K) := Tmp_Dig; end loop; Dividend (J) := Dividend (J) + Carry; -- [ TEST REMAINDER ] & [ ADD BACK ] (steps D5 and D6) -- Here there is a slight difference from the book: the last -- carry is always added in above and below (cancelling each -- other). In fact the dividend going negative is used as -- the test. -- If the Dividend went negative, then Q_Guess was off by -- one, so it is decremented, and the divisor is added back -- into the relevant portion of the dividend. if Dividend (J) < Int_0 then Q_Guess := Q_Guess - 1; Carry := 0; for K in reverse Divisor'Range loop Tmp_Int := Dividend (J + K) + Divisor (K) + Carry; if Tmp_Int >= Base then Tmp_Int := Tmp_Int - Base; Carry := 1; else Carry := 0; end if; Dividend (J + K) := Tmp_Int; end loop; Dividend (J) := Dividend (J) + Carry; end if; -- Finally we can get the next quotient digit Quotient_V (J) := Q_Guess; end loop; -- [ UNNORMALIZE ] (step D8) if not Discard_Quotient then Quotient := Vector_To_Uint (Quotient_V, (L_Vec (1) < Int_0 xor R_Vec (1) < Int_0)); end if; if not Discard_Remainder then declare Remainder_V : UI_Vector (1 .. R_Length); Discard_Int : Int; pragma Warnings (Off, Discard_Int); begin UI_Div_Vector (Dividend (Dividend'Last - R_Length + 1 .. Dividend'Last), D, Remainder_V, Discard_Int); Remainder := Vector_To_Uint (Remainder_V, L_Vec (1) < Int_0); end; end if; end Algorithm_D; end; end UI_Div_Rem; ------------ -- UI_Eq -- ------------ function UI_Eq (Left : Int; Right : Uint) return Boolean is begin return not UI_Ne (UI_From_Int (Left), Right); end UI_Eq; function UI_Eq (Left : Uint; Right : Int) return Boolean is begin return not UI_Ne (Left, UI_From_Int (Right)); end UI_Eq; function UI_Eq (Left : Uint; Right : Uint) return Boolean is begin return not UI_Ne (Left, Right); end UI_Eq; -------------- -- UI_Expon -- -------------- function UI_Expon (Left : Int; Right : Uint) return Uint is begin return UI_Expon (UI_From_Int (Left), Right); end UI_Expon; function UI_Expon (Left : Uint; Right : Int) return Uint is begin return UI_Expon (Left, UI_From_Int (Right)); end UI_Expon; function UI_Expon (Left : Int; Right : Int) return Uint is begin return UI_Expon (UI_From_Int (Left), UI_From_Int (Right)); end UI_Expon; function UI_Expon (Left : Uint; Right : Uint) return Uint is begin pragma Assert (Right >= Uint_0); -- Any value raised to power of 0 is 1 if Right = Uint_0 then return Uint_1; -- 0 to any positive power is 0 elsif Left = Uint_0 then return Uint_0; -- 1 to any power is 1 elsif Left = Uint_1 then return Uint_1; -- Any value raised to power of 1 is that value elsif Right = Uint_1 then return Left; -- Cases which can be done by table lookup elsif Right <= Uint_64 then -- 2 ** N for N in 2 .. 64 if Left = Uint_2 then declare Right_Int : constant Int := Direct_Val (Right); begin if Right_Int > UI_Power_2_Set then for J in UI_Power_2_Set + Int_1 .. Right_Int loop UI_Power_2 (J) := UI_Power_2 (J - Int_1) * Int_2; Uints_Min := Uints.Last; Udigits_Min := Udigits.Last; end loop; UI_Power_2_Set := Right_Int; end if; return UI_Power_2 (Right_Int); end; -- 10 ** N for N in 2 .. 64 elsif Left = Uint_10 then declare Right_Int : constant Int := Direct_Val (Right); begin if Right_Int > UI_Power_10_Set then for J in UI_Power_10_Set + Int_1 .. Right_Int loop UI_Power_10 (J) := UI_Power_10 (J - Int_1) * Int (10); Uints_Min := Uints.Last; Udigits_Min := Udigits.Last; end loop; UI_Power_10_Set := Right_Int; end if; return UI_Power_10 (Right_Int); end; end if; end if; -- If we fall through, then we have the general case (see Knuth 4.6.3) declare N : Uint := Right; Squares : Uint := Left; Result : Uint := Uint_1; M : constant Uintp.Save_Mark := Uintp.Mark; begin loop if (Least_Sig_Digit (N) mod Int_2) = Int_1 then Result := Result * Squares; end if; N := N / Uint_2; exit when N = Uint_0; Squares := Squares * Squares; end loop; Uintp.Release_And_Save (M, Result); return Result; end; end UI_Expon; ---------------- -- UI_From_CC -- ---------------- function UI_From_CC (Input : Char_Code) return Uint is begin return UI_From_Dint (Dint (Input)); end UI_From_CC; ------------------ -- UI_From_Dint -- ------------------ function UI_From_Dint (Input : Dint) return Uint is begin if Dint (Min_Direct) <= Input and then Input <= Dint (Max_Direct) then return Uint (Dint (Uint_Direct_Bias) + Input); -- For values of larger magnitude, compute digits into a vector and call -- Vector_To_Uint. else declare Max_For_Dint : constant := 5; -- Base is defined so that 5 Uint digits is sufficient to hold the -- largest possible Dint value. V : UI_Vector (1 .. Max_For_Dint); Temp_Integer : Dint; begin for J in V'Range loop V (J) := 0; end loop; Temp_Integer := Input; for J in reverse V'Range loop V (J) := Int (abs (Temp_Integer rem Dint (Base))); Temp_Integer := Temp_Integer / Dint (Base); end loop; return Vector_To_Uint (V, Input < Dint'(0)); end; end if; end UI_From_Dint; ----------------- -- UI_From_Int -- ----------------- function UI_From_Int (Input : Int) return Uint is U : Uint; begin if Min_Direct <= Input and then Input <= Max_Direct then return Uint (Int (Uint_Direct_Bias) + Input); end if; -- If already in the hash table, return entry U := UI_Ints.Get (Input); if U /= No_Uint then return U; end if; -- For values of larger magnitude, compute digits into a vector and call -- Vector_To_Uint. declare Max_For_Int : constant := 3; -- Base is defined so that 3 Uint digits is sufficient to hold the -- largest possible Int value. V : UI_Vector (1 .. Max_For_Int); Temp_Integer : Int; begin for J in V'Range loop V (J) := 0; end loop; Temp_Integer := Input; for J in reverse V'Range loop V (J) := abs (Temp_Integer rem Base); Temp_Integer := Temp_Integer / Base; end loop; U := Vector_To_Uint (V, Input < Int_0); UI_Ints.Set (Input, U); Uints_Min := Uints.Last; Udigits_Min := Udigits.Last; return U; end; end UI_From_Int; ------------ -- UI_GCD -- ------------ -- Lehmer's algorithm for GCD -- The idea is to avoid using multiple precision arithmetic wherever -- possible, substituting Int arithmetic instead. See Knuth volume II, -- Algorithm L (page 329). -- We use the same notation as Knuth (U_Hat standing for the obvious!) function UI_GCD (Uin, Vin : Uint) return Uint is U, V : Uint; -- Copies of Uin and Vin U_Hat, V_Hat : Int; -- The most Significant digits of U,V A, B, C, D, T, Q, Den1, Den2 : Int; Tmp_UI : Uint; Marks : constant Uintp.Save_Mark := Uintp.Mark; Iterations : Integer := 0; begin pragma Assert (Uin >= Vin); pragma Assert (Vin >= Uint_0); U := Uin; V := Vin; loop Iterations := Iterations + 1; if Direct (V) then if V = Uint_0 then return U; else return UI_From_Int (GCD (Direct_Val (V), UI_To_Int (U rem V))); end if; end if; Most_Sig_2_Digits (U, V, U_Hat, V_Hat); A := 1; B := 0; C := 0; D := 1; loop -- We might overflow and get division by zero here. This just -- means we cannot take the single precision step Den1 := V_Hat + C; Den2 := V_Hat + D; exit when Den1 = Int_0 or else Den2 = Int_0; -- Compute Q, the trial quotient Q := (U_Hat + A) / Den1; exit when Q /= ((U_Hat + B) / Den2); -- A single precision step Euclid step will give same answer as a -- multiprecision one. T := A - (Q * C); A := C; C := T; T := B - (Q * D); B := D; D := T; T := U_Hat - (Q * V_Hat); U_Hat := V_Hat; V_Hat := T; end loop; -- Take a multiprecision Euclid step if B = Int_0 then -- No single precision steps take a regular Euclid step Tmp_UI := U rem V; U := V; V := Tmp_UI; else -- Use prior single precision steps to compute this Euclid step -- For constructs such as: -- sqrt_2: constant := 1.41421_35623_73095_04880_16887_24209_698; -- sqrt_eps: constant long_float := long_float( 1.0 / sqrt_2) -- ** long_float'machine_mantissa; -- -- we spend 80% of our time working on this step. Perhaps we need -- a special case Int / Uint dot product to speed things up. ??? -- Alternatively we could increase the single precision iterations -- to handle Uint's of some small size ( <5 digits?). Then we -- would have more iterations on small Uint. On the code above, we -- only get 5 (on average) single precision iterations per large -- iteration. ??? Tmp_UI := (UI_From_Int (A) * U) + (UI_From_Int (B) * V); V := (UI_From_Int (C) * U) + (UI_From_Int (D) * V); U := Tmp_UI; end if; -- If the operands are very different in magnitude, the loop will -- generate large amounts of short-lived data, which it is worth -- removing periodically. if Iterations > 100 then Release_And_Save (Marks, U, V); Iterations := 0; end if; end loop; end UI_GCD; ------------ -- UI_Ge -- ------------ function UI_Ge (Left : Int; Right : Uint) return Boolean is begin return not UI_Lt (UI_From_Int (Left), Right); end UI_Ge; function UI_Ge (Left : Uint; Right : Int) return Boolean is begin return not UI_Lt (Left, UI_From_Int (Right)); end UI_Ge; function UI_Ge (Left : Uint; Right : Uint) return Boolean is begin return not UI_Lt (Left, Right); end UI_Ge; ------------ -- UI_Gt -- ------------ function UI_Gt (Left : Int; Right : Uint) return Boolean is begin return UI_Lt (Right, UI_From_Int (Left)); end UI_Gt; function UI_Gt (Left : Uint; Right : Int) return Boolean is begin return UI_Lt (UI_From_Int (Right), Left); end UI_Gt; function UI_Gt (Left : Uint; Right : Uint) return Boolean is begin return UI_Lt (Left => Right, Right => Left); end UI_Gt; --------------- -- UI_Image -- --------------- procedure UI_Image (Input : Uint; Format : UI_Format := Auto) is begin Image_Out (Input, True, Format); end UI_Image; ------------------------- -- UI_Is_In_Int_Range -- ------------------------- function UI_Is_In_Int_Range (Input : Uint) return Boolean is begin -- Make sure we don't get called before Initialize pragma Assert (Uint_Int_First /= Uint_0); if Direct (Input) then return True; else return Input >= Uint_Int_First and then Input <= Uint_Int_Last; end if; end UI_Is_In_Int_Range; ------------ -- UI_Le -- ------------ function UI_Le (Left : Int; Right : Uint) return Boolean is begin return not UI_Lt (Right, UI_From_Int (Left)); end UI_Le; function UI_Le (Left : Uint; Right : Int) return Boolean is begin return not UI_Lt (UI_From_Int (Right), Left); end UI_Le; function UI_Le (Left : Uint; Right : Uint) return Boolean is begin return not UI_Lt (Left => Right, Right => Left); end UI_Le; ------------ -- UI_Lt -- ------------ function UI_Lt (Left : Int; Right : Uint) return Boolean is begin return UI_Lt (UI_From_Int (Left), Right); end UI_Lt; function UI_Lt (Left : Uint; Right : Int) return Boolean is begin return UI_Lt (Left, UI_From_Int (Right)); end UI_Lt; function UI_Lt (Left : Uint; Right : Uint) return Boolean is begin -- Quick processing for identical arguments if Int (Left) = Int (Right) then return False; -- Quick processing for both arguments directly represented elsif Direct (Left) and then Direct (Right) then return Int (Left) < Int (Right); -- At least one argument is more than one digit long else declare L_Length : constant Int := N_Digits (Left); R_Length : constant Int := N_Digits (Right); L_Vec : UI_Vector (1 .. L_Length); R_Vec : UI_Vector (1 .. R_Length); begin Init_Operand (Left, L_Vec); Init_Operand (Right, R_Vec); if L_Vec (1) < Int_0 then -- First argument negative, second argument non-negative if R_Vec (1) >= Int_0 then return True; -- Both arguments negative else if L_Length /= R_Length then return L_Length > R_Length; elsif L_Vec (1) /= R_Vec (1) then return L_Vec (1) < R_Vec (1); else for J in 2 .. L_Vec'Last loop if L_Vec (J) /= R_Vec (J) then return L_Vec (J) > R_Vec (J); end if; end loop; return False; end if; end if; else -- First argument non-negative, second argument negative if R_Vec (1) < Int_0 then return False; -- Both arguments non-negative else if L_Length /= R_Length then return L_Length < R_Length; else for J in L_Vec'Range loop if L_Vec (J) /= R_Vec (J) then return L_Vec (J) < R_Vec (J); end if; end loop; return False; end if; end if; end if; end; end if; end UI_Lt; ------------ -- UI_Max -- ------------ function UI_Max (Left : Int; Right : Uint) return Uint is begin return UI_Max (UI_From_Int (Left), Right); end UI_Max; function UI_Max (Left : Uint; Right : Int) return Uint is begin return UI_Max (Left, UI_From_Int (Right)); end UI_Max; function UI_Max (Left : Uint; Right : Uint) return Uint is begin if Left >= Right then return Left; else return Right; end if; end UI_Max; ------------ -- UI_Min -- ------------ function UI_Min (Left : Int; Right : Uint) return Uint is begin return UI_Min (UI_From_Int (Left), Right); end UI_Min; function UI_Min (Left : Uint; Right : Int) return Uint is begin return UI_Min (Left, UI_From_Int (Right)); end UI_Min; function UI_Min (Left : Uint; Right : Uint) return Uint is begin if Left <= Right then return Left; else return Right; end if; end UI_Min; ------------- -- UI_Mod -- ------------- function UI_Mod (Left : Int; Right : Uint) return Uint is begin return UI_Mod (UI_From_Int (Left), Right); end UI_Mod; function UI_Mod (Left : Uint; Right : Int) return Uint is begin return UI_Mod (Left, UI_From_Int (Right)); end UI_Mod; function UI_Mod (Left : Uint; Right : Uint) return Uint is Urem : constant Uint := Left rem Right; begin if (Left < Uint_0) = (Right < Uint_0) or else Urem = Uint_0 then return Urem; else return Right + Urem; end if; end UI_Mod; ------------------------------- -- UI_Modular_Exponentiation -- ------------------------------- function UI_Modular_Exponentiation (B : Uint; E : Uint; Modulo : Uint) return Uint is M : constant Save_Mark := Mark; Result : Uint := Uint_1; Base : Uint := B; Exponent : Uint := E; begin while Exponent /= Uint_0 loop if Least_Sig_Digit (Exponent) rem Int'(2) = Int'(1) then Result := (Result * Base) rem Modulo; end if; Exponent := Exponent / Uint_2; Base := (Base * Base) rem Modulo; end loop; Release_And_Save (M, Result); return Result; end UI_Modular_Exponentiation; ------------------------ -- UI_Modular_Inverse -- ------------------------ function UI_Modular_Inverse (N : Uint; Modulo : Uint) return Uint is M : constant Save_Mark := Mark; U : Uint; V : Uint; Q : Uint; R : Uint; X : Uint; Y : Uint; T : Uint; S : Int := 1; begin U := Modulo; V := N; X := Uint_1; Y := Uint_0; loop UI_Div_Rem (U, V, Quotient => Q, Remainder => R, Discard_Quotient => False, Discard_Remainder => False); U := V; V := R; T := X; X := Y + Q * X; Y := T; S := -S; exit when R = Uint_1; end loop; if S = Int'(-1) then X := Modulo - X; end if; Release_And_Save (M, X); return X; end UI_Modular_Inverse; ------------ -- UI_Mul -- ------------ function UI_Mul (Left : Int; Right : Uint) return Uint is begin return UI_Mul (UI_From_Int (Left), Right); end UI_Mul; function UI_Mul (Left : Uint; Right : Int) return Uint is begin return UI_Mul (Left, UI_From_Int (Right)); end UI_Mul; function UI_Mul (Left : Uint; Right : Uint) return Uint is begin -- Simple case of single length operands if Direct (Left) and then Direct (Right) then return UI_From_Dint (Dint (Direct_Val (Left)) * Dint (Direct_Val (Right))); end if; -- Otherwise we have the general case (Algorithm M in Knuth) declare L_Length : constant Int := N_Digits (Left); R_Length : constant Int := N_Digits (Right); L_Vec : UI_Vector (1 .. L_Length); R_Vec : UI_Vector (1 .. R_Length); Neg : Boolean; begin Init_Operand (Left, L_Vec); Init_Operand (Right, R_Vec); Neg := (L_Vec (1) < Int_0) xor (R_Vec (1) < Int_0); L_Vec (1) := abs (L_Vec (1)); R_Vec (1) := abs (R_Vec (1)); Algorithm_M : declare Product : UI_Vector (1 .. L_Length + R_Length); Tmp_Sum : Int; Carry : Int; begin for J in Product'Range loop Product (J) := 0; end loop; for J in reverse R_Vec'Range loop Carry := 0; for K in reverse L_Vec'Range loop Tmp_Sum := L_Vec (K) * R_Vec (J) + Product (J + K) + Carry; Product (J + K) := Tmp_Sum rem Base; Carry := Tmp_Sum / Base; end loop; Product (J) := Carry; end loop; return Vector_To_Uint (Product, Neg); end Algorithm_M; end; end UI_Mul; ------------ -- UI_Ne -- ------------ function UI_Ne (Left : Int; Right : Uint) return Boolean is begin return UI_Ne (UI_From_Int (Left), Right); end UI_Ne; function UI_Ne (Left : Uint; Right : Int) return Boolean is begin return UI_Ne (Left, UI_From_Int (Right)); end UI_Ne; function UI_Ne (Left : Uint; Right : Uint) return Boolean is begin -- Quick processing for identical arguments. Note that this takes -- care of the case of two No_Uint arguments. if Int (Left) = Int (Right) then return False; end if; -- See if left operand directly represented if Direct (Left) then -- If right operand directly represented then compare if Direct (Right) then return Int (Left) /= Int (Right); -- Left operand directly represented, right not, must be unequal else return True; end if; -- Right operand directly represented, left not, must be unequal elsif Direct (Right) then return True; end if; -- Otherwise both multi-word, do comparison declare Size : constant Int := N_Digits (Left); Left_Loc : Int; Right_Loc : Int; begin if Size /= N_Digits (Right) then return True; end if; Left_Loc := Uints.Table (Left).Loc; Right_Loc := Uints.Table (Right).Loc; for J in Int_0 .. Size - Int_1 loop if Udigits.Table (Left_Loc + J) /= Udigits.Table (Right_Loc + J) then return True; end if; end loop; return False; end; end UI_Ne; ---------------- -- UI_Negate -- ---------------- function UI_Negate (Right : Uint) return Uint is begin -- Case where input is directly represented. Note that since the range -- of Direct values is non-symmetrical, the result may not be directly -- represented, this is taken care of in UI_From_Int. if Direct (Right) then return UI_From_Int (-Direct_Val (Right)); -- Full processing for multi-digit case. Note that we cannot just copy -- the value to the end of the table negating the first digit, since the -- range of Direct values is non-symmetrical, so we can have a negative -- value that is not Direct whose negation can be represented directly. else declare R_Length : constant Int := N_Digits (Right); R_Vec : UI_Vector (1 .. R_Length); Neg : Boolean; begin Init_Operand (Right, R_Vec); Neg := R_Vec (1) > Int_0; R_Vec (1) := abs R_Vec (1); return Vector_To_Uint (R_Vec, Neg); end; end if; end UI_Negate; ------------- -- UI_Rem -- ------------- function UI_Rem (Left : Int; Right : Uint) return Uint is begin return UI_Rem (UI_From_Int (Left), Right); end UI_Rem; function UI_Rem (Left : Uint; Right : Int) return Uint is begin return UI_Rem (Left, UI_From_Int (Right)); end UI_Rem; function UI_Rem (Left, Right : Uint) return Uint is Sign : Int; Tmp : Int; subtype Int1_12 is Integer range 1 .. 12; begin pragma Assert (Right /= Uint_0); if Direct (Right) then if Direct (Left) then return UI_From_Int (Direct_Val (Left) rem Direct_Val (Right)); else -- Special cases when Right is less than 13 and Left is larger -- larger than one digit. All of these algorithms depend on the -- base being 2 ** 15 We work with Abs (Left) and Abs(Right) -- then multiply result by Sign (Left) if (Right <= Uint_12) and then (Right >= Uint_Minus_12) then if Left < Uint_0 then Sign := -1; else Sign := 1; end if; -- All cases are listed, grouped by mathematical method It is -- not inefficient to do have this case list out of order since -- GCC sorts the cases we list. case Int1_12 (abs (Direct_Val (Right))) is when 1 => return Uint_0; -- Powers of two are simple AND's with LS Left Digit GCC -- will recognise these constants as powers of 2 and replace -- the rem with simpler operations where possible. -- Least_Sig_Digit might return Negative numbers when 2 => return UI_From_Int ( Sign * (Least_Sig_Digit (Left) mod 2)); when 4 => return UI_From_Int ( Sign * (Least_Sig_Digit (Left) mod 4)); when 8 => return UI_From_Int ( Sign * (Least_Sig_Digit (Left) mod 8)); -- Some number theoretical tricks: -- If B Rem Right = 1 then -- Left Rem Right = Sum_Of_Digits_Base_B (Left) Rem Right -- Note: 2^32 mod 3 = 1 when 3 => return UI_From_Int ( Sign * (Sum_Double_Digits (Left, 1) rem Int (3))); -- Note: 2^15 mod 7 = 1 when 7 => return UI_From_Int ( Sign * (Sum_Digits (Left, 1) rem Int (7))); -- Note: 2^32 mod 5 = -1 -- Alternating sums might be negative, but rem is always -- positive hence we must use mod here. when 5 => Tmp := Sum_Double_Digits (Left, -1) mod Int (5); return UI_From_Int (Sign * Tmp); -- Note: 2^15 mod 9 = -1 -- Alternating sums might be negative, but rem is always -- positive hence we must use mod here. when 9 => Tmp := Sum_Digits (Left, -1) mod Int (9); return UI_From_Int (Sign * Tmp); -- Note: 2^15 mod 11 = -1 -- Alternating sums might be negative, but rem is always -- positive hence we must use mod here. when 11 => Tmp := Sum_Digits (Left, -1) mod Int (11); return UI_From_Int (Sign * Tmp); -- Now resort to Chinese Remainder theorem to reduce 6, 10, -- 12 to previous special cases -- There is no reason we could not add more cases like these -- if it proves useful. -- Perhaps we should go up to 16, however we have no "trick" -- for 13. -- To find u mod m we: -- Pick m1, m2 S.T. -- GCD(m1, m2) = 1 AND m = (m1 * m2). -- Next we pick (Basis) M1, M2 small S.T. -- (M1 mod m1) = (M2 mod m2) = 1 AND -- (M1 mod m2) = (M2 mod m1) = 0 -- So u mod m = (u1 * M1 + u2 * M2) mod m Where u1 = (u mod -- m1) AND u2 = (u mod m2); Under typical circumstances the -- last mod m can be done with a (possible) single -- subtraction. -- m1 = 2; m2 = 3; M1 = 3; M2 = 4; when 6 => Tmp := 3 * (Least_Sig_Digit (Left) rem 2) + 4 * (Sum_Double_Digits (Left, 1) rem 3); return UI_From_Int (Sign * (Tmp rem 6)); -- m1 = 2; m2 = 5; M1 = 5; M2 = 6; when 10 => Tmp := 5 * (Least_Sig_Digit (Left) rem 2) + 6 * (Sum_Double_Digits (Left, -1) mod 5); return UI_From_Int (Sign * (Tmp rem 10)); -- m1 = 3; m2 = 4; M1 = 4; M2 = 9; when 12 => Tmp := 4 * (Sum_Double_Digits (Left, 1) rem 3) + 9 * (Least_Sig_Digit (Left) rem 4); return UI_From_Int (Sign * (Tmp rem 12)); end case; end if; -- Else fall through to general case -- The special case Length (Left) = Length (Right) = 1 in Div -- looks slow. It uses UI_To_Int when Int should suffice. ??? end if; end if; declare Remainder : Uint; Quotient : Uint; pragma Warnings (Off, Quotient); begin UI_Div_Rem (Left, Right, Quotient, Remainder, Discard_Quotient => True, Discard_Remainder => False); return Remainder; end; end UI_Rem; ------------ -- UI_Sub -- ------------ function UI_Sub (Left : Int; Right : Uint) return Uint is begin return UI_Add (Left, -Right); end UI_Sub; function UI_Sub (Left : Uint; Right : Int) return Uint is begin return UI_Add (Left, -Right); end UI_Sub; function UI_Sub (Left : Uint; Right : Uint) return Uint is begin if Direct (Left) and then Direct (Right) then return UI_From_Int (Direct_Val (Left) - Direct_Val (Right)); else return UI_Add (Left, -Right); end if; end UI_Sub; -------------- -- UI_To_CC -- -------------- function UI_To_CC (Input : Uint) return Char_Code is begin if Direct (Input) then return Char_Code (Direct_Val (Input)); -- Case of input is more than one digit else declare In_Length : constant Int := N_Digits (Input); In_Vec : UI_Vector (1 .. In_Length); Ret_CC : Char_Code; begin Init_Operand (Input, In_Vec); -- We assume value is positive Ret_CC := 0; for Idx in In_Vec'Range loop Ret_CC := Ret_CC * Char_Code (Base) + Char_Code (abs In_Vec (Idx)); end loop; return Ret_CC; end; end if; end UI_To_CC; ---------------- -- UI_To_Int -- ---------------- function UI_To_Int (Input : Uint) return Int is begin if Direct (Input) then return Direct_Val (Input); -- Case of input is more than one digit else declare In_Length : constant Int := N_Digits (Input); In_Vec : UI_Vector (1 .. In_Length); Ret_Int : Int; begin -- Uints of more than one digit could be outside the range for -- Ints. Caller should have checked for this if not certain. -- Fatal error to attempt to convert from value outside Int'Range. pragma Assert (UI_Is_In_Int_Range (Input)); -- Otherwise, proceed ahead, we are OK Init_Operand (Input, In_Vec); Ret_Int := 0; -- Calculate -|Input| and then negates if value is positive. This -- handles our current definition of Int (based on 2s complement). -- Is it secure enough??? for Idx in In_Vec'Range loop Ret_Int := Ret_Int * Base - abs In_Vec (Idx); end loop; if In_Vec (1) < Int_0 then return Ret_Int; else return -Ret_Int; end if; end; end if; end UI_To_Int; -------------- -- UI_Write -- -------------- procedure UI_Write (Input : Uint; Format : UI_Format := Auto) is begin Image_Out (Input, False, Format); end UI_Write; --------------------- -- Vector_To_Uint -- --------------------- function Vector_To_Uint (In_Vec : UI_Vector; Negative : Boolean) return Uint is Size : Int; Val : Int; begin -- The vector can contain leading zeros. These are not stored in the -- table, so loop through the vector looking for first non-zero digit for J in In_Vec'Range loop if In_Vec (J) /= Int_0 then -- The length of the value is the length of the rest of the vector Size := In_Vec'Last - J + 1; -- One digit value can always be represented directly if Size = Int_1 then if Negative then return Uint (Int (Uint_Direct_Bias) - In_Vec (J)); else return Uint (Int (Uint_Direct_Bias) + In_Vec (J)); end if; -- Positive two digit values may be in direct representation range elsif Size = Int_2 and then not Negative then Val := In_Vec (J) * Base + In_Vec (J + 1); if Val <= Max_Direct then return Uint (Int (Uint_Direct_Bias) + Val); end if; end if; -- The value is outside the direct representation range and must -- therefore be stored in the table. Expand the table to contain -- the count and digits. The index of the new table entry will be -- returned as the result. Uints.Append ((Length => Size, Loc => Udigits.Last + 1)); if Negative then Val := -In_Vec (J); else Val := +In_Vec (J); end if; Udigits.Append (Val); for K in 2 .. Size loop Udigits.Append (In_Vec (J + K - 1)); end loop; return Uints.Last; end if; end loop; -- Dropped through loop only if vector contained all zeros return Uint_0; end Vector_To_Uint; end Uintp;