URL https://opencores.org/ocsvn/openrisc_me/openrisc_me/trunk
Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [urealp.adb] - Blame information for rev 315

Go to most recent revision | Details | Compare with Previous | View Log

------------------------------------------------------------------------------
--                                                                          --
--                         GNAT COMPILER COMPONENTS                         --
--                                                                          --
--                               U R E A L 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 Alloc;
with Output;  use Output;
with Table;
with Tree_IO; use Tree_IO;
 
package body Urealp is
 
   Ureal_First_Entry : constant Ureal := Ureal'Succ (No_Ureal);
   --  First subscript allocated in Ureal table (note that we can't just
   --  add 1 to No_Ureal, since "+" means something different for Ureals!
 
   type Ureal_Entry is record
      Num  : Uint;
      --  Numerator (always non-negative)
 
      Den  : Uint;
      --  Denominator (always non-zero, always positive if base is zero)
 
      Rbase : Nat;
      --  Base value. If Rbase is zero, then the value is simply Num / Den.
      --  If Rbase is non-zero, then the value is Num / (Rbase ** Den)
 
      Negative : Boolean;
      --  Flag set if value is negative
   end record;
 
   --  The following representation clause ensures that the above record
   --  has no holes. We do this so that when instances of this record are
   --  written by Tree_Gen, we do not write uninitialized values to the file.
 
   for Ureal_Entry use record
      Num      at  0 range 0 .. 31;
      Den      at  4 range 0 .. 31;
      Rbase    at  8 range 0 .. 31;
      Negative at 12 range 0 .. 31;
   end record;
 
   for Ureal_Entry'Size use 16 * 8;
   --  This ensures that we did not leave out any fields
 
   package Ureals is new Table.Table (
     Table_Component_Type => Ureal_Entry,
     Table_Index_Type     => Ureal'Base,
     Table_Low_Bound      => Ureal_First_Entry,
     Table_Initial        => Alloc.Ureals_Initial,
     Table_Increment      => Alloc.Ureals_Increment,
     Table_Name           => "Ureals");
 
   --  The following universal reals are the values returned by the constant
   --  functions. They are initialized by the initialization procedure.
 
   UR_0          : Ureal;
   UR_M_0        : Ureal;
   UR_Tenth      : Ureal;
   UR_Half       : Ureal;
   UR_1          : Ureal;
   UR_2          : Ureal;
   UR_10         : Ureal;
   UR_10_36      : Ureal;
   UR_M_10_36    : Ureal;
   UR_100        : Ureal;
   UR_2_128      : Ureal;
   UR_2_80       : Ureal;
   UR_2_M_128    : Ureal;
   UR_2_M_80     : Ureal;
 
   Num_Ureal_Constants : constant := 10;
   --  This is used for an assertion check in Tree_Read and Tree_Write to
   --  help remember to add values to these routines when we add to the list.
 
   Normalized_Real : Ureal := No_Ureal;
   --  Used to memoize Norm_Num and Norm_Den, if either of these functions
   --  is called, this value is set and Normalized_Entry contains the result
   --  of the normalization. On subsequent calls, this is used to avoid the
   --  call to Normalize if it has already been made.
 
   Normalized_Entry : Ureal_Entry;
   --  Entry built by most recent call to Normalize
 
   -----------------------
   -- Local Subprograms --
   -----------------------
 
   function Decimal_Exponent_Hi (V : Ureal) return Int;
   --  Returns an estimate of the exponent of Val represented as a normalized
   --  decimal number (non-zero digit before decimal point), The estimate is
   --  either correct, or high, but never low. The accuracy of the estimate
   --  affects only the efficiency of the comparison routines.
 
   function Decimal_Exponent_Lo (V : Ureal) return Int;
   --  Returns an estimate of the exponent of Val represented as a normalized
   --  decimal number (non-zero digit before decimal point), The estimate is
   --  either correct, or low, but never high. The accuracy of the estimate
   --  affects only the efficiency of the comparison routines.
 
   function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int;
   --  U is a Ureal entry for which the base value is non-zero, the value
   --  returned is the equivalent decimal exponent value, i.e. the value of
   --  Den, adjusted as though the base were base 10. The value is rounded
   --  to the nearest integer, and so can be one off.
 
   function Is_Integer (Num, Den : Uint) return Boolean;
   --  Return true if the real quotient of Num / Den is an integer value
 
   function Normalize (Val : Ureal_Entry) return Ureal_Entry;
   --  Normalizes the Ureal_Entry by reducing it to lowest terms (with a
   --  base value of 0).
 
   function Same (U1, U2 : Ureal) return Boolean;
   pragma Inline (Same);
   --  Determines if U1 and U2 are the same Ureal. Note that we cannot use
   --  the equals operator for this test, since that tests for equality,
   --  not identity.
 
   function Store_Ureal (Val : Ureal_Entry) return Ureal;
   --  This store a new entry in the universal reals table and return
   --  its index in the table.
 
   -------------------------
   -- Decimal_Exponent_Hi --
   -------------------------
 
   function Decimal_Exponent_Hi (V : Ureal) return Int is
      Val : constant Ureal_Entry := Ureals.Table (V);
 
   begin
      --  Zero always returns zero
 
      if UR_Is_Zero (V) then
         return 0;
 
      --  For numbers in rational form, get the maximum number of digits in the
      --  numerator and the minimum number of digits in the denominator, and
      --  subtract. For example:
 
      --     1000 / 99 = 1.010E+1
      --     9999 / 10 = 9.999E+2
 
      --  This estimate may of course be high, but that is acceptable
 
      elsif Val.Rbase = 0 then
         return UI_Decimal_Digits_Hi (Val.Num) -
                UI_Decimal_Digits_Lo (Val.Den);
 
      --  For based numbers, just subtract the decimal exponent from the
      --  high estimate of the number of digits in the numerator and add
      --  one to accommodate possible round off errors for non-decimal
      --  bases. For example:
 
      --     1_500_000 / 10**4 = 1.50E-2
 
      else -- Val.Rbase /= 0
         return UI_Decimal_Digits_Hi (Val.Num) -
                Equivalent_Decimal_Exponent (Val) + 1;
      end if;
   end Decimal_Exponent_Hi;
 
   -------------------------
   -- Decimal_Exponent_Lo --
   -------------------------
 
   function Decimal_Exponent_Lo (V : Ureal) return Int is
      Val : constant Ureal_Entry := Ureals.Table (V);
 
   begin
      --  Zero always returns zero
 
      if UR_Is_Zero (V) then
         return 0;
 
      --  For numbers in rational form, get min digits in numerator, max digits
      --  in denominator, and subtract and subtract one more for possible loss
      --  during the division. For example:
 
      --     1000 / 99 = 1.010E+1
      --     9999 / 10 = 9.999E+2
 
      --  This estimate may of course be low, but that is acceptable
 
      elsif Val.Rbase = 0 then
         return UI_Decimal_Digits_Lo (Val.Num) -
                UI_Decimal_Digits_Hi (Val.Den) - 1;
 
      --  For based numbers, just subtract the decimal exponent from the
      --  low estimate of the number of digits in the numerator and subtract
      --  one to accommodate possible round off errors for non-decimal
      --  bases. For example:
 
      --     1_500_000 / 10**4 = 1.50E-2
 
      else -- Val.Rbase /= 0
         return UI_Decimal_Digits_Lo (Val.Num) -
                Equivalent_Decimal_Exponent (Val) - 1;
      end if;
   end Decimal_Exponent_Lo;
 
   -----------------
   -- Denominator --
   -----------------
 
   function Denominator (Real : Ureal) return Uint is
   begin
      return Ureals.Table (Real).Den;
   end Denominator;
 
   ---------------------------------
   -- Equivalent_Decimal_Exponent --
   ---------------------------------
 
   function Equivalent_Decimal_Exponent (U : Ureal_Entry) return Int is
 
      --  The following table is a table of logs to the base 10
 
      Logs : constant array (Nat range 1 .. 16) of Long_Float := (
                1 => 0.000000000000000,
                2 => 0.301029995663981,
                3 => 0.477121254719662,
                4 => 0.602059991327962,
                5 => 0.698970004336019,
                6 => 0.778151250383644,
                7 => 0.845098040014257,
                8 => 0.903089986991944,
                9 => 0.954242509439325,
               10 => 1.000000000000000,
               11 => 1.041392685158230,
               12 => 1.079181246047620,
               13 => 1.113943352306840,
               14 => 1.146128035678240,
               15 => 1.176091259055680,
               16 => 1.204119982655920);
 
   begin
      pragma Assert (U.Rbase /= 0);
      return Int (Long_Float (UI_To_Int (U.Den)) * Logs (U.Rbase));
   end Equivalent_Decimal_Exponent;
 
   ----------------
   -- Initialize --
   ----------------
 
   procedure Initialize is
   begin
      Ureals.Init;
      UR_0       := UR_From_Components (Uint_0, Uint_1,         0, False);
      UR_M_0     := UR_From_Components (Uint_0, Uint_1,         0, True);
      UR_Half    := UR_From_Components (Uint_1, Uint_1,         2, False);
      UR_Tenth   := UR_From_Components (Uint_1, Uint_1,        10, False);
      UR_1       := UR_From_Components (Uint_1, Uint_1,         0, False);
      UR_2       := UR_From_Components (Uint_1, Uint_Minus_1,   2, False);
      UR_10      := UR_From_Components (Uint_1, Uint_Minus_1,  10, False);
      UR_10_36   := UR_From_Components (Uint_1, Uint_Minus_36, 10, False);
      UR_M_10_36 := UR_From_Components (Uint_1, Uint_Minus_36, 10, True);
      UR_100     := UR_From_Components (Uint_1, Uint_Minus_2,  10, False);
      UR_2_128   := UR_From_Components (Uint_1, Uint_Minus_128, 2, False);
      UR_2_M_128 := UR_From_Components (Uint_1, Uint_128,       2, False);
      UR_2_80    := UR_From_Components (Uint_1, Uint_Minus_80,  2, False);
      UR_2_M_80  := UR_From_Components (Uint_1, Uint_80,        2, False);
   end Initialize;
 
   ----------------
   -- Is_Integer --
   ----------------
 
   function Is_Integer (Num, Den : Uint) return Boolean is
   begin
      return (Num / Den) * Den = Num;
   end Is_Integer;
 
   ----------
   -- Mark --
   ----------
 
   function Mark return Save_Mark is
   begin
      return Save_Mark (Ureals.Last);
   end Mark;
 
   --------------
   -- Norm_Den --
   --------------
 
   function Norm_Den (Real : Ureal) return Uint is
   begin
      if not Same (Real, Normalized_Real) then
         Normalized_Real  := Real;
         Normalized_Entry := Normalize (Ureals.Table (Real));
      end if;
 
      return Normalized_Entry.Den;
   end Norm_Den;
 
   --------------
   -- Norm_Num --
   --------------
 
   function Norm_Num (Real : Ureal) return Uint is
   begin
      if not Same (Real, Normalized_Real) then
         Normalized_Real  := Real;
         Normalized_Entry := Normalize (Ureals.Table (Real));
      end if;
 
      return Normalized_Entry.Num;
   end Norm_Num;
 
   ---------------
   -- Normalize --
   ---------------
 
   function Normalize (Val : Ureal_Entry) return Ureal_Entry is
      J   : Uint;
      K   : Uint;
      Tmp : Uint;
      Num : Uint;
      Den : Uint;
      M   : constant Uintp.Save_Mark := Uintp.Mark;
 
   begin
      --  Start by setting J to the greatest of the absolute values of the
      --  numerator and the denominator (taking into account the base value),
      --  and K to the lesser of the two absolute values. The gcd of Num and
      --  Den is the gcd of J and K.
 
      if Val.Rbase = 0 then
         J := Val.Num;
         K := Val.Den;
 
      elsif Val.Den < 0 then
         J := Val.Num * Val.Rbase ** (-Val.Den);
         K := Uint_1;
 
      else
         J := Val.Num;
         K := Val.Rbase ** Val.Den;
      end if;
 
      Num := J;
      Den := K;
 
      if K > J then
         Tmp := J;
         J := K;
         K := Tmp;
      end if;
 
      J := UI_GCD (J, K);
      Num := Num / J;
      Den := Den / J;
      Uintp.Release_And_Save (M, Num, Den);
 
      --  Divide numerator and denominator by gcd and return result
 
      return (Num      => Num,
              Den      => Den,
              Rbase    => 0,
              Negative => Val.Negative);
   end Normalize;
 
   ---------------
   -- Numerator --
   ---------------
 
   function Numerator (Real : Ureal) return Uint is
   begin
      return Ureals.Table (Real).Num;
   end Numerator;
 
   --------
   -- pr --
   --------
 
   procedure pr (Real : Ureal) is
   begin
      UR_Write (Real);
      Write_Eol;
   end pr;
 
   -----------
   -- Rbase --
   -----------
 
   function Rbase (Real : Ureal) return Nat is
   begin
      return Ureals.Table (Real).Rbase;
   end Rbase;
 
   -------------
   -- Release --
   -------------
 
   procedure Release (M : Save_Mark) is
   begin
      Ureals.Set_Last (Ureal (M));
   end Release;
 
   ----------
   -- Same --
   ----------
 
   function Same (U1, U2 : Ureal) return Boolean is
   begin
      return Int (U1) = Int (U2);
   end Same;
 
   -----------------
   -- Store_Ureal --
   -----------------
 
   function Store_Ureal (Val : Ureal_Entry) return Ureal is
   begin
      Ureals.Append (Val);
 
      --  Normalize representation of signed values
 
      if Val.Num < 0 then
         Ureals.Table (Ureals.Last).Negative := True;
         Ureals.Table (Ureals.Last).Num := -Val.Num;
      end if;
 
      return Ureals.Last;
   end Store_Ureal;
 
   ---------------
   -- Tree_Read --
   ---------------
 
   procedure Tree_Read is
   begin
      pragma Assert (Num_Ureal_Constants = 10);
 
      Ureals.Tree_Read;
      Tree_Read_Int (Int (UR_0));
      Tree_Read_Int (Int (UR_M_0));
      Tree_Read_Int (Int (UR_Tenth));
      Tree_Read_Int (Int (UR_Half));
      Tree_Read_Int (Int (UR_1));
      Tree_Read_Int (Int (UR_2));
      Tree_Read_Int (Int (UR_10));
      Tree_Read_Int (Int (UR_100));
      Tree_Read_Int (Int (UR_2_128));
      Tree_Read_Int (Int (UR_2_M_128));
 
      --  Clear the normalization cache
 
      Normalized_Real := No_Ureal;
   end Tree_Read;
 
   ----------------
   -- Tree_Write --
   ----------------
 
   procedure Tree_Write is
   begin
      pragma Assert (Num_Ureal_Constants = 10);
 
      Ureals.Tree_Write;
      Tree_Write_Int (Int (UR_0));
      Tree_Write_Int (Int (UR_M_0));
      Tree_Write_Int (Int (UR_Tenth));
      Tree_Write_Int (Int (UR_Half));
      Tree_Write_Int (Int (UR_1));
      Tree_Write_Int (Int (UR_2));
      Tree_Write_Int (Int (UR_10));
      Tree_Write_Int (Int (UR_100));
      Tree_Write_Int (Int (UR_2_128));
      Tree_Write_Int (Int (UR_2_M_128));
   end Tree_Write;
 
   ------------
   -- UR_Abs --
   ------------
 
   function UR_Abs (Real : Ureal) return Ureal is
      Val : constant Ureal_Entry := Ureals.Table (Real);
 
   begin
      return Store_Ureal (
               (Num      => Val.Num,
                Den      => Val.Den,
                Rbase    => Val.Rbase,
                Negative => False));
   end UR_Abs;
 
   ------------
   -- UR_Add --
   ------------
 
   function UR_Add (Left : Uint; Right : Ureal) return Ureal is
   begin
      return UR_From_Uint (Left) + Right;
   end UR_Add;
 
   function UR_Add (Left : Ureal; Right : Uint) return Ureal is
   begin
      return Left + UR_From_Uint (Right);
   end UR_Add;
 
   function UR_Add (Left : Ureal; Right : Ureal) return Ureal is
      Lval : Ureal_Entry := Ureals.Table (Left);
      Rval : Ureal_Entry := Ureals.Table (Right);
 
      Num  : Uint;
 
   begin
      --  Note, in the temporary Ureal_Entry values used in this procedure,
      --  we store the sign as the sign of the numerator (i.e. xxx.Num may
      --  be negative, even though in stored entries this can never be so)
 
      if Lval.Rbase /= 0 and then Lval.Rbase = Rval.Rbase then
 
         declare
            Opd_Min, Opd_Max   : Ureal_Entry;
            Exp_Min, Exp_Max   : Uint;
 
         begin
            if Lval.Negative then
               Lval.Num := (-Lval.Num);
            end if;
 
            if Rval.Negative then
               Rval.Num := (-Rval.Num);
            end if;
 
            if Lval.Den < Rval.Den then
               Exp_Min := Lval.Den;
               Exp_Max := Rval.Den;
               Opd_Min := Lval;
               Opd_Max := Rval;
            else
               Exp_Min := Rval.Den;
               Exp_Max := Lval.Den;
               Opd_Min := Rval;
               Opd_Max := Lval;
            end if;
 
            Num :=
              Opd_Min.Num * Lval.Rbase ** (Exp_Max - Exp_Min) + Opd_Max.Num;
 
            if Num = 0 then
               return Store_Ureal (
                        (Num      => Uint_0,
                         Den      => Uint_1,
                         Rbase    => 0,
                         Negative => Lval.Negative));
 
            else
               return Store_Ureal (
                        (Num      => abs Num,
                         Den      => Exp_Max,
                         Rbase    => Lval.Rbase,
                         Negative => (Num < 0)));
            end if;
         end;
 
      else
         declare
            Ln : Ureal_Entry := Normalize (Lval);
            Rn : Ureal_Entry := Normalize (Rval);
 
         begin
            if Ln.Negative then
               Ln.Num := (-Ln.Num);
            end if;
 
            if Rn.Negative then
               Rn.Num := (-Rn.Num);
            end if;
 
            Num := (Ln.Num * Rn.Den) + (Rn.Num * Ln.Den);
 
            if Num = 0 then
               return Store_Ureal (
                        (Num      => Uint_0,
                         Den      => Uint_1,
                         Rbase    => 0,
                         Negative => Lval.Negative));
 
            else
               return Store_Ureal (
                        Normalize (
                          (Num      => abs Num,
                           Den      => Ln.Den * Rn.Den,
                           Rbase    => 0,
                           Negative => (Num < 0))));
            end if;
         end;
      end if;
   end UR_Add;
 
   ----------------
   -- UR_Ceiling --
   ----------------
 
   function UR_Ceiling (Real : Ureal) return Uint is
      Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
 
   begin
      if Val.Negative then
         return UI_Negate (Val.Num / Val.Den);
      else
         return (Val.Num + Val.Den - 1) / Val.Den;
      end if;
   end UR_Ceiling;
 
   ------------
   -- UR_Div --
   ------------
 
   function UR_Div (Left : Uint; Right : Ureal) return Ureal is
   begin
      return UR_From_Uint (Left) / Right;
   end UR_Div;
 
   function UR_Div (Left : Ureal; Right : Uint) return Ureal is
   begin
      return Left / UR_From_Uint (Right);
   end UR_Div;
 
   function UR_Div (Left, Right : Ureal) return Ureal is
      Lval : constant Ureal_Entry := Ureals.Table (Left);
      Rval : constant Ureal_Entry := Ureals.Table (Right);
      Rneg : constant Boolean     := Rval.Negative xor Lval.Negative;
 
   begin
      pragma Assert (Rval.Num /= Uint_0);
 
      if Lval.Rbase = 0 then
 
         if Rval.Rbase = 0 then
            return Store_Ureal (
                     Normalize (
                       (Num      => Lval.Num * Rval.Den,
                        Den      => Lval.Den * Rval.Num,
                        Rbase    => 0,
                        Negative => Rneg)));
 
         elsif Is_Integer (Lval.Num, Rval.Num * Lval.Den) then
            return Store_Ureal (
                     (Num      => Lval.Num / (Rval.Num * Lval.Den),
                      Den      => (-Rval.Den),
                      Rbase    => Rval.Rbase,
                      Negative => Rneg));
 
         elsif Rval.Den < 0 then
            return Store_Ureal (
                     Normalize (
                       (Num      => Lval.Num,
                        Den      => Rval.Rbase ** (-Rval.Den) *
                                    Rval.Num *
                                    Lval.Den,
                        Rbase    => 0,
                        Negative => Rneg)));
 
         else
            return Store_Ureal (
                     Normalize (
                       (Num      => Lval.Num * Rval.Rbase ** Rval.Den,
                        Den      => Rval.Num * Lval.Den,
                        Rbase    => 0,
                        Negative => Rneg)));
         end if;
 
      elsif Is_Integer (Lval.Num, Rval.Num) then
 
         if Rval.Rbase = Lval.Rbase then
            return Store_Ureal (
                     (Num      => Lval.Num / Rval.Num,
                      Den      => Lval.Den - Rval.Den,
                      Rbase    => Lval.Rbase,
                      Negative => Rneg));
 
         elsif Rval.Rbase = 0 then
            return Store_Ureal (
                     (Num      => (Lval.Num / Rval.Num) * Rval.Den,
                      Den      => Lval.Den,
                      Rbase    => Lval.Rbase,
                      Negative => Rneg));
 
         elsif Rval.Den < 0 then
            declare
               Num, Den : Uint;
 
            begin
               if Lval.Den < 0 then
                  Num := (Lval.Num / Rval.Num) * (Lval.Rbase ** (-Lval.Den));
                  Den := Rval.Rbase ** (-Rval.Den);
               else
                  Num := Lval.Num / Rval.Num;
                  Den := (Lval.Rbase ** Lval.Den) *
                         (Rval.Rbase ** (-Rval.Den));
               end if;
 
               return Store_Ureal (
                        (Num      => Num,
                         Den      => Den,
                         Rbase    => 0,
                         Negative => Rneg));
            end;
 
         else
            return Store_Ureal (
                     (Num      => (Lval.Num / Rval.Num) *
                                  (Rval.Rbase ** Rval.Den),
                      Den      => Lval.Den,
                      Rbase    => Lval.Rbase,
                      Negative => Rneg));
         end if;
 
      else
         declare
            Num, Den : Uint;
 
         begin
            if Lval.Den < 0 then
               Num := Lval.Num * (Lval.Rbase ** (-Lval.Den));
               Den := Rval.Num;
 
            else
               Num := Lval.Num;
               Den := Rval.Num * (Lval.Rbase ** Lval.Den);
            end if;
 
            if Rval.Rbase /= 0 then
               if Rval.Den < 0 then
                  Den := Den * (Rval.Rbase ** (-Rval.Den));
               else
                  Num := Num * (Rval.Rbase ** Rval.Den);
               end if;
 
            else
               Num := Num * Rval.Den;
            end if;
 
            return Store_Ureal (
                     Normalize (
                       (Num      => Num,
                        Den      => Den,
                        Rbase    => 0,
                        Negative => Rneg)));
         end;
      end if;
   end UR_Div;
 
   -----------
   -- UR_Eq --
   -----------
 
   function UR_Eq (Left, Right : Ureal) return Boolean is
   begin
      return not UR_Ne (Left, Right);
   end UR_Eq;
 
   ---------------------
   -- UR_Exponentiate --
   ---------------------
 
   function UR_Exponentiate (Real : Ureal; N : Uint) return Ureal is
      X    : constant Uint := abs N;
      Bas  : Ureal;
      Val  : Ureal_Entry;
      Neg  : Boolean;
      IBas : Uint;
 
   begin
      --  If base is negative, then the resulting sign depends on whether
      --  the exponent is even or odd (even => positive, odd = negative)
 
      if UR_Is_Negative (Real) then
         Neg := (N mod 2) /= 0;
         Bas := UR_Negate (Real);
      else
         Neg := False;
         Bas := Real;
      end if;
 
      Val := Ureals.Table (Bas);
 
      --  If the base is a small integer, then we can return the result in
      --  exponential form, which can save a lot of time for junk exponents.
 
      IBas := UR_Trunc (Bas);
 
      if IBas <= 16
        and then UR_From_Uint (IBas) = Bas
      then
         return Store_Ureal (
                 (Num      => Uint_1,
                  Den      => -N,
                  Rbase    => UI_To_Int (UR_Trunc (Bas)),
                  Negative => Neg));
 
      --  If the exponent is negative then we raise the numerator and the
      --  denominator (after normalization) to the absolute value of the
      --  exponent and we return the reciprocal. An assert error will happen
      --  if the numerator is zero.
 
      elsif N < 0 then
         pragma Assert (Val.Num /= 0);
         Val := Normalize (Val);
 
         return Store_Ureal (
                 (Num      => Val.Den ** X,
                  Den      => Val.Num ** X,
                  Rbase    => 0,
                  Negative => Neg));
 
      --  If positive, we distinguish the case when the base is not zero, in
      --  which case the new denominator is just the product of the old one
      --  with the exponent,
 
      else
         if Val.Rbase /= 0 then
 
            return Store_Ureal (
                    (Num      => Val.Num ** X,
                     Den      => Val.Den * X,
                     Rbase    => Val.Rbase,
                     Negative => Neg));
 
         --  And when the base is zero, in which case we exponentiate
         --  the old denominator.
 
         else
            return Store_Ureal (
                    (Num      => Val.Num ** X,
                     Den      => Val.Den ** X,
                     Rbase    => 0,
                     Negative => Neg));
         end if;
      end if;
   end UR_Exponentiate;
 
   --------------
   -- UR_Floor --
   --------------
 
   function UR_Floor (Real : Ureal) return Uint is
      Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
 
   begin
      if Val.Negative then
         return UI_Negate ((Val.Num + Val.Den - 1) / Val.Den);
      else
         return Val.Num / Val.Den;
      end if;
   end UR_Floor;
 
   ------------------------
   -- UR_From_Components --
   ------------------------
 
   function UR_From_Components
     (Num      : Uint;
      Den      : Uint;
      Rbase    : Nat := 0;
      Negative : Boolean := False)
      return     Ureal
   is
   begin
      return Store_Ureal (
               (Num      => Num,
                Den      => Den,
                Rbase    => Rbase,
                Negative => Negative));
   end UR_From_Components;
 
   ------------------
   -- UR_From_Uint --
   ------------------
 
   function UR_From_Uint (UI : Uint) return Ureal is
   begin
      return UR_From_Components
        (abs UI, Uint_1, Negative => (UI < 0));
   end UR_From_Uint;
 
   -----------
   -- UR_Ge --
   -----------
 
   function UR_Ge (Left, Right : Ureal) return Boolean is
   begin
      return not (Left < Right);
   end UR_Ge;
 
   -----------
   -- UR_Gt --
   -----------
 
   function UR_Gt (Left, Right : Ureal) return Boolean is
   begin
      return (Right < Left);
   end UR_Gt;
 
   --------------------
   -- UR_Is_Negative --
   --------------------
 
   function UR_Is_Negative (Real : Ureal) return Boolean is
   begin
      return Ureals.Table (Real).Negative;
   end UR_Is_Negative;
 
   --------------------
   -- UR_Is_Positive --
   --------------------
 
   function UR_Is_Positive (Real : Ureal) return Boolean is
   begin
      return not Ureals.Table (Real).Negative
        and then Ureals.Table (Real).Num /= 0;
   end UR_Is_Positive;
 
   ----------------
   -- UR_Is_Zero --
   ----------------
 
   function UR_Is_Zero (Real : Ureal) return Boolean is
   begin
      return Ureals.Table (Real).Num = 0;
   end UR_Is_Zero;
 
   -----------
   -- UR_Le --
   -----------
 
   function UR_Le (Left, Right : Ureal) return Boolean is
   begin
      return not (Right < Left);
   end UR_Le;
 
   -----------
   -- UR_Lt --
   -----------
 
   function UR_Lt (Left, Right : Ureal) return Boolean is
   begin
      --  An operand is not less than itself
 
      if Same (Left, Right) then
         return False;
 
      --  Deal with zero cases
 
      elsif UR_Is_Zero (Left) then
         return UR_Is_Positive (Right);
 
      elsif UR_Is_Zero (Right) then
         return Ureals.Table (Left).Negative;
 
      --  Different signs are decisive (note we dealt with zero cases)
 
      elsif Ureals.Table (Left).Negative
        and then not Ureals.Table (Right).Negative
      then
         return True;
 
      elsif not Ureals.Table (Left).Negative
        and then Ureals.Table (Right).Negative
      then
         return False;
 
      --  Signs are same, do rapid check based on worst case estimates of
      --  decimal exponent, which will often be decisive. Precise test
      --  depends on whether operands are positive or negative.
 
      elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) then
         return UR_Is_Positive (Left);
 
      elsif Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right) then
         return UR_Is_Negative (Left);
 
      --  If we fall through, full gruesome test is required. This happens
      --  if the numbers are close together, or in some weird (/=10) base.
 
      else
         declare
            Imrk   : constant Uintp.Save_Mark  := Mark;
            Rmrk   : constant Urealp.Save_Mark := Mark;
            Lval   : Ureal_Entry;
            Rval   : Ureal_Entry;
            Result : Boolean;
 
         begin
            Lval := Ureals.Table (Left);
            Rval := Ureals.Table (Right);
 
            --  An optimization. If both numbers are based, then subtract
            --  common value of base to avoid unnecessarily giant numbers
 
            if Lval.Rbase = Rval.Rbase and then Lval.Rbase /= 0 then
               if Lval.Den < Rval.Den then
                  Rval.Den := Rval.Den - Lval.Den;
                  Lval.Den := Uint_0;
               else
                  Lval.Den := Lval.Den - Rval.Den;
                  Rval.Den := Uint_0;
               end if;
            end if;
 
            Lval := Normalize (Lval);
            Rval := Normalize (Rval);
 
            if Lval.Negative then
               Result := (Lval.Num * Rval.Den) > (Rval.Num * Lval.Den);
            else
               Result := (Lval.Num * Rval.Den) < (Rval.Num * Lval.Den);
            end if;
 
            Release (Imrk);
            Release (Rmrk);
            return Result;
         end;
      end if;
   end UR_Lt;
 
   ------------
   -- UR_Max --
   ------------
 
   function UR_Max (Left, Right : Ureal) return Ureal is
   begin
      if Left >= Right then
         return Left;
      else
         return Right;
      end if;
   end UR_Max;
 
   ------------
   -- UR_Min --
   ------------
 
   function UR_Min (Left, Right : Ureal) return Ureal is
   begin
      if Left <= Right then
         return Left;
      else
         return Right;
      end if;
   end UR_Min;
 
   ------------
   -- UR_Mul --
   ------------
 
   function UR_Mul (Left : Uint; Right : Ureal) return Ureal is
   begin
      return UR_From_Uint (Left) * Right;
   end UR_Mul;
 
   function UR_Mul (Left : Ureal; Right : Uint) return Ureal is
   begin
      return Left * UR_From_Uint (Right);
   end UR_Mul;
 
   function UR_Mul (Left, Right : Ureal) return Ureal is
      Lval : constant Ureal_Entry := Ureals.Table (Left);
      Rval : constant Ureal_Entry := Ureals.Table (Right);
      Num  : Uint                 := Lval.Num * Rval.Num;
      Den  : Uint;
      Rneg : constant Boolean     := Lval.Negative xor Rval.Negative;
 
   begin
      if Lval.Rbase = 0 then
         if Rval.Rbase = 0 then
            return Store_Ureal (
                     Normalize (
                        (Num      => Num,
                         Den      => Lval.Den * Rval.Den,
                         Rbase    => 0,
                         Negative => Rneg)));
 
         elsif Is_Integer (Num, Lval.Den) then
            return Store_Ureal (
                     (Num      => Num / Lval.Den,
                      Den      => Rval.Den,
                      Rbase    => Rval.Rbase,
                      Negative => Rneg));
 
         elsif Rval.Den < 0 then
            return Store_Ureal (
                     Normalize (
                       (Num      => Num * (Rval.Rbase ** (-Rval.Den)),
                        Den      => Lval.Den,
                        Rbase    => 0,
                        Negative => Rneg)));
 
         else
            return Store_Ureal (
                     Normalize (
                       (Num      => Num,
                        Den      => Lval.Den * (Rval.Rbase ** Rval.Den),
                        Rbase    => 0,
                        Negative => Rneg)));
         end if;
 
      elsif Lval.Rbase = Rval.Rbase then
         return Store_Ureal (
                  (Num      => Num,
                   Den      => Lval.Den + Rval.Den,
                   Rbase    => Lval.Rbase,
                   Negative => Rneg));
 
      elsif Rval.Rbase = 0 then
         if Is_Integer (Num, Rval.Den) then
            return Store_Ureal (
                     (Num      => Num / Rval.Den,
                      Den      => Lval.Den,
                      Rbase    => Lval.Rbase,
                      Negative => Rneg));
 
         elsif Lval.Den < 0 then
            return Store_Ureal (
                     Normalize (
                       (Num      => Num * (Lval.Rbase ** (-Lval.Den)),
                        Den      => Rval.Den,
                        Rbase    => 0,
                        Negative => Rneg)));
 
         else
            return Store_Ureal (
                     Normalize (
                       (Num      => Num,
                        Den      => Rval.Den * (Lval.Rbase ** Lval.Den),
                        Rbase    => 0,
                        Negative => Rneg)));
         end if;
 
      else
         Den := Uint_1;
 
         if Lval.Den < 0 then
            Num := Num * (Lval.Rbase ** (-Lval.Den));
         else
            Den := Den * (Lval.Rbase ** Lval.Den);
         end if;
 
         if Rval.Den < 0 then
            Num := Num * (Rval.Rbase ** (-Rval.Den));
         else
            Den := Den * (Rval.Rbase ** Rval.Den);
         end if;
 
         return Store_Ureal (
                  Normalize (
                    (Num      => Num,
                     Den      => Den,
                     Rbase    => 0,
                     Negative => Rneg)));
      end if;
   end UR_Mul;
 
   -----------
   -- UR_Ne --
   -----------
 
   function UR_Ne (Left, Right : Ureal) return Boolean is
   begin
      --  Quick processing for case of identical Ureal values (note that
      --  this also deals with comparing two No_Ureal values).
 
      if Same (Left, Right) then
         return False;
 
      --  Deal with case of one or other operand is No_Ureal, but not both
 
      elsif Same (Left, No_Ureal) or else Same (Right, No_Ureal) then
         return True;
 
      --  Do quick check based on number of decimal digits
 
      elsif Decimal_Exponent_Hi (Left) < Decimal_Exponent_Lo (Right) or else
            Decimal_Exponent_Lo (Left) > Decimal_Exponent_Hi (Right)
      then
         return True;
 
      --  Otherwise full comparison is required
 
      else
         declare
            Imrk   : constant Uintp.Save_Mark  := Mark;
            Rmrk   : constant Urealp.Save_Mark := Mark;
            Lval   : constant Ureal_Entry := Normalize (Ureals.Table (Left));
            Rval   : constant Ureal_Entry := Normalize (Ureals.Table (Right));
            Result : Boolean;
 
         begin
            if UR_Is_Zero (Left) then
               return not UR_Is_Zero (Right);
 
            elsif UR_Is_Zero (Right) then
               return not UR_Is_Zero (Left);
 
            --  Both operands are non-zero
 
            else
               Result :=
                  Rval.Negative /= Lval.Negative
                   or else Rval.Num /= Lval.Num
                   or else Rval.Den /= Lval.Den;
               Release (Imrk);
               Release (Rmrk);
               return Result;
            end if;
         end;
      end if;
   end UR_Ne;
 
   ---------------
   -- UR_Negate --
   ---------------
 
   function UR_Negate (Real : Ureal) return Ureal is
   begin
      return Store_Ureal (
               (Num      => Ureals.Table (Real).Num,
                Den      => Ureals.Table (Real).Den,
                Rbase    => Ureals.Table (Real).Rbase,
                Negative => not Ureals.Table (Real).Negative));
   end UR_Negate;
 
   ------------
   -- UR_Sub --
   ------------
 
   function UR_Sub (Left : Uint; Right : Ureal) return Ureal is
   begin
      return UR_From_Uint (Left) + UR_Negate (Right);
   end UR_Sub;
 
   function UR_Sub (Left : Ureal; Right : Uint) return Ureal is
   begin
      return Left + UR_From_Uint (-Right);
   end UR_Sub;
 
   function UR_Sub (Left, Right : Ureal) return Ureal is
   begin
      return Left + UR_Negate (Right);
   end UR_Sub;
 
   ----------------
   -- UR_To_Uint --
   ----------------
 
   function UR_To_Uint (Real : Ureal) return Uint is
      Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
      Res : Uint;
 
   begin
      Res := (Val.Num + (Val.Den / 2)) / Val.Den;
 
      if Val.Negative then
         return UI_Negate (Res);
      else
         return Res;
      end if;
   end UR_To_Uint;
 
   --------------
   -- UR_Trunc --
   --------------
 
   function UR_Trunc (Real : Ureal) return Uint is
      Val : constant Ureal_Entry := Normalize (Ureals.Table (Real));
 
   begin
      if Val.Negative then
         return -(Val.Num / Val.Den);
      else
         return Val.Num / Val.Den;
      end if;
   end UR_Trunc;
 
   --------------
   -- UR_Write --
   --------------
 
   procedure UR_Write (Real : Ureal) is
      Val : constant Ureal_Entry := Ureals.Table (Real);
 
   begin
      --  If value is negative, we precede the constant by a minus sign
      --  and add an extra layer of parentheses on the outside since the
      --  minus sign is part of the value, not a negation operator.
 
      if Val.Negative then
         Write_Str ("(-");
      end if;
 
      --  Constants in base 10 can be written in normal Ada literal style
 
      if Val.Rbase = 10 then
         UI_Write (Val.Num / 10);
         Write_Char ('.');
         UI_Write (Val.Num mod 10);
 
         if Val.Den /= 0 then
            Write_Char ('E');
            UI_Write (1 - Val.Den);
         end if;
 
      --  Constants in a base other than 10 can still be easily written
      --  in normal Ada literal style if the numerator is one.
 
      elsif Val.Rbase /= 0 and then Val.Num = 1 then
         Write_Int (Val.Rbase);
         Write_Str ("#1.0#E");
         UI_Write (-Val.Den);
 
      --  Other constants with a base other than 10 are written using one
      --  of the following forms, depending on the sign of the number
      --  and the sign of the exponent (= minus denominator value)
 
      --    (numerator.0*base**exponent)
      --    (numerator.0*base**(-exponent))
 
      elsif Val.Rbase /= 0 then
         Write_Char ('(');
         UI_Write (Val.Num, Decimal);
         Write_Str (".0*");
         Write_Int (Val.Rbase);
         Write_Str ("**");
 
         if Val.Den <= 0 then
            UI_Write (-Val.Den, Decimal);
 
         else
            Write_Str ("(-");
            UI_Write (Val.Den, Decimal);
            Write_Char (')');
         end if;
 
         Write_Char (')');
 
      --  Rational constants with a denominator of 1 can be written as
      --  a real literal for the numerator integer.
 
      elsif Val.Den = 1 then
         UI_Write (Val.Num, Decimal);
         Write_Str (".0");
 
      --  Non-based (rational) constants are written in (num/den) style
 
      else
         Write_Char ('(');
         UI_Write (Val.Num, Decimal);
         Write_Str (".0/");
         UI_Write (Val.Den, Decimal);
         Write_Str (".0)");
      end if;
 
      --  Add trailing paren for negative values
 
      if Val.Negative then
         Write_Char (')');
      end if;
   end UR_Write;
 
   -------------
   -- Ureal_0 --
   -------------
 
   function Ureal_0 return Ureal is
   begin
      return UR_0;
   end Ureal_0;
 
   -------------
   -- Ureal_1 --
   -------------
 
   function Ureal_1 return Ureal is
   begin
      return UR_1;
   end Ureal_1;
 
   -------------
   -- Ureal_2 --
   -------------
 
   function Ureal_2 return Ureal is
   begin
      return UR_2;
   end Ureal_2;
 
   --------------
   -- Ureal_10 --
   --------------
 
   function Ureal_10 return Ureal is
   begin
      return UR_10;
   end Ureal_10;
 
   ---------------
   -- Ureal_100 --
   ---------------
 
   function Ureal_100 return Ureal is
   begin
      return UR_100;
   end Ureal_100;
 
   -----------------
   -- Ureal_10_36 --
   -----------------
 
   function Ureal_10_36 return Ureal is
   begin
      return UR_10_36;
   end Ureal_10_36;
 
   ----------------
   -- Ureal_2_80 --
   ----------------
 
   function Ureal_2_80 return Ureal is
   begin
      return UR_2_80;
   end Ureal_2_80;
 
   -----------------
   -- Ureal_2_128 --
   -----------------
 
   function Ureal_2_128 return Ureal is
   begin
      return UR_2_128;
   end Ureal_2_128;
 
   -------------------
   -- Ureal_2_M_80 --
   -------------------
 
   function Ureal_2_M_80 return Ureal is
   begin
      return UR_2_M_80;
   end Ureal_2_M_80;
 
   -------------------
   -- Ureal_2_M_128 --
   -------------------
 
   function Ureal_2_M_128 return Ureal is
   begin
      return UR_2_M_128;
   end Ureal_2_M_128;
 
   ----------------
   -- Ureal_Half --
   ----------------
 
   function Ureal_Half return Ureal is
   begin
      return UR_Half;
   end Ureal_Half;
 
   ---------------
   -- Ureal_M_0 --
   ---------------
 
   function Ureal_M_0 return Ureal is
   begin
      return UR_M_0;
   end Ureal_M_0;
 
   -------------------
   -- Ureal_M_10_36 --
   -------------------
 
   function Ureal_M_10_36 return Ureal is
   begin
      return UR_M_10_36;
   end Ureal_M_10_36;
 
   -----------------
   -- Ureal_Tenth --
   -----------------
 
   function Ureal_Tenth return Ureal is
   begin
      return UR_Tenth;
   end Ureal_Tenth;
 
end Urealp;
Browse

Tools

Subversion Repositories openrisc_me

[/] [openrisc/] [trunk/] [gnu-src/] [gcc-4.5.1/] [gcc/] [ada/] [urealp.adb] - Blame information for rev 315

Line No.	Rev	Author	Line
1	281	jeremybenn	`------------------------------------------------------------------------------`
2			`-- --`
3			`-- GNAT COMPILER COMPONENTS --`
4			`-- --`
5			`-- U R E A L P --`
6			`-- --`
7			`-- B o d y --`
8			`-- --`
9			`-- Copyright (C) 1992-2009 Free Software Foundation, Inc. --`
10			`-- --`
11			`-- GNAT is free software; you can redistribute it and/or modify it under --`
12			`-- terms of the GNU General Public License as published by the Free Soft- --`
13			`-- ware Foundation; either version 3, or (at your option) any later ver- --`
14			`-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --`
15			`-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --`
16			`-- or FITNESS FOR A PARTICULAR PURPOSE. --`
17			`-- --`
18			`-- As a special exception under Section 7 of GPL version 3, you are granted --`
19			`-- additional permissions described in the GCC Runtime Library Exception, --`
20			`-- version 3.1, as published by the Free Software Foundation. --`
21			`-- --`
22			`-- You should have received a copy of the GNU General Public License and --`
23			`-- a copy of the GCC Runtime Library Exception along with this program; --`
24			`-- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --`
25			`-- <http://www.gnu.org/licenses/>. --`
26			`-- --`
27			`-- GNAT was originally developed by the GNAT team at New York University. --`
28			`-- Extensive contributions were provided by Ada Core Technologies Inc. --`
29			`-- --`
30			`------------------------------------------------------------------------------`
31
32			`with Alloc;`
33			`with Output; use Output;`
34			`with Table;`
35			`with Tree_IO; use Tree_IO;`
36
37			`package body Urealp is`
38
39			`Ureal_First_Entry : constant Ureal := Ureal'Succ (No_Ureal);`
40			`-- First subscript allocated in Ureal table (note that we can't just`