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