gcc/ada/s-expgen.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --                       S Y S T E M . E X P _ G E N                        --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --          Copyright (C) 1992-2001, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, USA.                                                      --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- GNAT was originally developed  by the GNAT team at  New York University. --
  31 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 package body System.Exp_Gen is
  36
  37    --------------------
  38    -- Exp_Float_Type --
  39    --------------------
  40
  41    function Exp_Float_Type
  42      (Left  : Type_Of_Base;
  43       Right : Integer)
  44       return  Type_Of_Base
  45    is
  46       Result : Type_Of_Base := 1.0;
  47       Factor : Type_Of_Base := Left;
  48       Exp    : Integer := Right;
  49
  50    begin
  51       --  We use the standard logarithmic approach, Exp gets shifted right
  52       --  testing successive low order bits and Factor is the value of the
  53       --  base raised to the next power of 2. For positive exponents we
  54       --  multiply the result by this factor, for negative exponents, we
  55       --  divide by this factor.
  56
  57       if Exp >= 0 then
  58
  59          --  For a positive exponent, if we get a constraint error during
  60          --  this loop, it is an overflow, and the constraint error will
  61          --  simply be passed on to the caller.
  62
  63          loop
  64             if Exp rem 2 /= 0 then
  65                declare
  66                   pragma Unsuppress (All_Checks);
  67                begin
  68                   Result := Result * Factor;
  69                end;
  70             end if;
  71
  72             Exp := Exp / 2;
  73             exit when Exp = 0;
  74
  75             declare
  76                pragma Unsuppress (All_Checks);
  77             begin
  78                Factor := Factor * Factor;
  79             end;
  80          end loop;
  81
  82          return Result;
  83
  84       --  Now we know that the exponent is negative, check for case of
  85       --  base of 0.0 which always generates a constraint error.
  86
  87       elsif Factor = 0.0 then
  88          raise Constraint_Error;
  89
  90       --  Here we have a negative exponent with a non-zero base
  91
  92       else
  93
  94          --  For the negative exponent case, a constraint error during this
  95          --  calculation happens if Factor gets too large, and the proper
  96          --  response is to return 0.0, since what we essenmtially have is
  97          --  1.0 / infinity, and the closest model number will be zero.
  98
  99          begin
 100             loop
 101                if Exp rem 2 /= 0 then
 102                   declare
 103                      pragma Unsuppress (All_Checks);
 104                   begin
 105                      Result := Result * Factor;
 106                   end;
 107                end if;
 108
 109                Exp := Exp / 2;
 110                exit when Exp = 0;
 111
 112                declare
 113                   pragma Unsuppress (All_Checks);
 114                begin
 115                   Factor := Factor * Factor;
 116                end;
 117             end loop;
 118
 119             declare
 120                pragma Unsuppress (All_Checks);
 121             begin
 122                return 1.0 / Result;
 123             end;
 124
 125          exception
 126
 127             when Constraint_Error =>
 128                return 0.0;
 129          end;
 130       end if;
 131    end Exp_Float_Type;
 132
 133    ----------------------
 134    -- Exp_Integer_Type --
 135    ----------------------
 136
 137    --  Note that negative exponents get a constraint error because the
 138    --  subtype of the Right argument (the exponent) is Natural.
 139
 140    function Exp_Integer_Type
 141      (Left  : Type_Of_Base;
 142       Right : Natural)
 143       return  Type_Of_Base
 144    is
 145       Result : Type_Of_Base := 1;
 146       Factor : Type_Of_Base := Left;
 147       Exp    : Natural := Right;
 148
 149    begin
 150       --  We use the standard logarithmic approach, Exp gets shifted right
 151       --  testing successive low order bits and Factor is the value of the
 152       --  base raised to the next power of 2.
 153
 154       --  Note: it is not worth special casing the cases of base values -1,0,+1
 155       --  since the expander does this when the base is a literal, and other
 156       --  cases will be extremely rare.
 157
 158       if Exp /= 0 then
 159          loop
 160             if Exp rem 2 /= 0 then
 161                declare
 162                   pragma Unsuppress (All_Checks);
 163                begin
 164                   Result := Result * Factor;
 165                end;
 166             end if;
 167
 168             Exp := Exp / 2;
 169             exit when Exp = 0;
 170
 171             declare
 172                pragma Unsuppress (All_Checks);
 173             begin
 174                Factor := Factor * Factor;
 175             end;
 176          end loop;
 177       end if;
 178
 179       return Result;
 180    end Exp_Integer_Type;
 181
 182 end System.Exp_Gen;