+++ /dev/null
-------------------------------------------------------------------------------
--- --
--- GNAT COMPILER COMPONENTS --
--- --
--- U R E A L P --
--- --
--- B o d y --
--- --
--- $Revision: 1.2.12.1 $
--- --
--- Copyright (C) 1992-2001 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 2, 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. See the GNU General Public License --
--- for more details. You should have received a copy of the GNU General --
--- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
--- --
--- As a special exception, if other files instantiate generics from this --
--- unit, or you link this unit with other files to produce an executable, --
--- this unit does not by itself cause the resulting executable to be --
--- covered by the GNU General Public License. This exception does not --
--- however invalidate any other reasons why the executable file might be --
--- covered by the GNU Public License. --
--- --
--- 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;
-
- package Ureals is new Table.Table (
- Table_Component_Type => Ureal_Entry,
- Table_Index_Type => Ureal,
- 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_M_0 : Ureal;
- UR_0 : Ureal;
- UR_Tenth : Ureal;
- UR_Half : Ureal;
- UR_1 : Ureal;
- UR_2 : Ureal;
- UR_10 : Ureal;
- UR_100 : Ureal;
- UR_2_128 : Ureal;
- UR_2_M_128 : 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_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);
- 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.Increment_Last;
- Ureals.Table (Ureals.Last) := 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 : 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
- Bas : Ureal;
- Val : Ureal_Entry;
- X : Uint := abs N;
- 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 : 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 : 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 the literal is negative enclose in parens to emphasize that
- -- it is part of the constant, and not a separate negation operator
-
- 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_2_128 --
- -----------------
-
- function Ureal_2_128 return Ureal is
- begin
- return UR_2_128;
- end Ureal_2_128;
-
- -------------------
- -- 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_Tenth --
- -----------------
-
- function Ureal_Tenth return Ureal is
- begin
- return UR_Tenth;
- end Ureal_Tenth;
-
-end Urealp;
projects / msp430-gcc.git / blobdiff