OSDN Git Service

Daily bump.
[pf3gnuchains/gcc-fork.git] / 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;