gcc/ada/libgnat/s-exnllf.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                       S Y S T E M . E X N _ L L F                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2017, 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 --  Note: the reason for treating exponents in the range 0 .. 4 specially is
  33 --  to ensure identical results to the static inline expansion in the case of
  34 --  a compile time known exponent in this range. The use of Float'Machine and
  35 --  Long_Float'Machine is to avoid unwanted extra precision in the results.
  36
  37 --  Note that for a negative exponent in Left ** Right, we compute the result
  38 --  as:
  39
  40 --     1.0 / (Left ** (-Right))
  41
  42 --  Note that the case of Left being zero is not special, it will simply result
  43 --  in a division by zero at the end, yielding a correctly signed infinity, or
  44 --  possibly generating an overflow.
  45
  46 --  Note on overflow: This coding assumes that the target generates infinities
  47 --  with standard IEEE semantics. If this is not the case, then the code
  48 --  for negative exponent may raise Constraint_Error. This follows the
  49 --  implementation permission given in RM 4.5.6(12).
  50
  51 package body System.Exn_LLF is
  52
  53    subtype Negative is Integer range Integer'First .. -1;
  54
  55    function Exp
  56      (Left  : Long_Long_Float;
  57       Right : Natural) return Long_Long_Float;
  58    --  Common routine used if Right is greater or equal to 5
  59
  60    ---------------
  61    -- Exn_Float --
  62    ---------------
  63
  64    function Exn_Float
  65      (Left  : Float;
  66       Right : Integer) return Float
  67    is
  68       Temp : Float;
  69    begin
  70       case Right is
  71          when 0 =>
  72             return 1.0;
  73          when 1 =>
  74             return Left;
  75          when 2 =>
  76             return Float'Machine (Left * Left);
  77          when 3 =>
  78             return Float'Machine (Left * Left * Left);
  79          when 4 =>
  80             Temp := Float'Machine (Left * Left);
  81             return Float'Machine (Temp * Temp);
  82          when Negative =>
  83             return Float'Machine (1.0 / Exn_Float (Left, -Right));
  84          when others =>
  85             return
  86               Float'Machine
  87                 (Float (Exp (Long_Long_Float (Left), Right)));
  88       end case;
  89    end Exn_Float;
  90
  91    --------------------
  92    -- Exn_Long_Float --
  93    --------------------
  94
  95    function Exn_Long_Float
  96      (Left  : Long_Float;
  97       Right : Integer) return Long_Float
  98    is
  99       Temp : Long_Float;
 100    begin
 101       case Right is
 102          when 0 =>
 103             return 1.0;
 104          when 1 =>
 105             return Left;
 106          when 2 =>
 107             return Long_Float'Machine (Left * Left);
 108          when 3 =>
 109             return Long_Float'Machine (Left * Left * Left);
 110          when 4 =>
 111             Temp := Long_Float'Machine (Left * Left);
 112             return Long_Float'Machine (Temp * Temp);
 113          when Negative =>
 114             return Long_Float'Machine (1.0 / Exn_Long_Float (Left, -Right));
 115          when others =>
 116             return
 117               Long_Float'Machine
 118                 (Long_Float (Exp (Long_Long_Float (Left), Right)));
 119       end case;
 120    end Exn_Long_Float;
 121
 122    -------------------------
 123    -- Exn_Long_Long_Float --
 124    -------------------------
 125
 126    function Exn_Long_Long_Float
 127      (Left  : Long_Long_Float;
 128       Right : Integer) return Long_Long_Float
 129    is
 130       Temp : Long_Long_Float;
 131    begin
 132       case Right is
 133          when 0 =>
 134             return 1.0;
 135          when 1 =>
 136             return Left;
 137          when 2 =>
 138             return Left * Left;
 139          when 3 =>
 140             return Left * Left * Left;
 141          when 4 =>
 142             Temp := Left * Left;
 143             return Temp * Temp;
 144          when Negative =>
 145             return 1.0 / Exn_Long_Long_Float (Left, -Right);
 146          when others =>
 147             return Exp (Left, Right);
 148       end case;
 149    end Exn_Long_Long_Float;
 150
 151    ---------
 152    -- Exp --
 153    ---------
 154
 155    function Exp
 156      (Left  : Long_Long_Float;
 157       Right : Natural) return Long_Long_Float
 158    is
 159       Result : Long_Long_Float := 1.0;
 160       Factor : Long_Long_Float := Left;
 161       Exp    : Natural := Right;
 162
 163    begin
 164       --  We use the standard logarithmic approach, Exp gets shifted right
 165       --  testing successive low order bits and Factor is the value of the
 166       --  base raised to the next power of 2. If the low order bit or Exp is
 167       --  set, multiply the result by this factor.
 168
 169       loop
 170          if Exp rem 2 /= 0 then
 171             Result := Result * Factor;
 172          end if;
 173
 174          Exp := Exp / 2;
 175          exit when Exp = 0;
 176          Factor := Factor * Factor;
 177       end loop;
 178
 179       return Result;
 180    end Exp;
 181
 182 end System.Exn_LLF;