1 ------------------------------------------------------------------------------
3 -- GNAT RUNTIME COMPONENTS --
5 -- S Y S T E M . E X P _ G E N --
10 -- Copyright (C) 1992-2001, Free Software Foundation, Inc. --
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. --
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. --
30 -- GNAT was originally developed by the GNAT team at New York University. --
31 -- Extensive contributions were provided by Ada Core Technologies Inc. --
33 ------------------------------------------------------------------------------
35 package body System.Exp_Gen is
41 function Exp_Float_Type
46 Result : Type_Of_Base := 1.0;
47 Factor : Type_Of_Base := Left;
48 Exp : Integer := Right;
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.
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.
64 if Exp rem 2 /= 0 then
66 pragma Unsuppress (All_Checks);
68 Result := Result * Factor;
76 pragma Unsuppress (All_Checks);
78 Factor := Factor * Factor;
84 -- Now we know that the exponent is negative, check for case of
85 -- base of 0.0 which always generates a constraint error.
87 elsif Factor = 0.0 then
88 raise Constraint_Error;
90 -- Here we have a negative exponent with a non-zero base
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.
101 if Exp rem 2 /= 0 then
103 pragma Unsuppress (All_Checks);
105 Result := Result * Factor;
113 pragma Unsuppress (All_Checks);
115 Factor := Factor * Factor;
120 pragma Unsuppress (All_Checks);
127 when Constraint_Error =>
133 ----------------------
134 -- Exp_Integer_Type --
135 ----------------------
137 -- Note that negative exponents get a constraint error because the
138 -- subtype of the Right argument (the exponent) is Natural.
140 function Exp_Integer_Type
141 (Left : Type_Of_Base;
145 Result : Type_Of_Base := 1;
146 Factor : Type_Of_Base := Left;
147 Exp : Natural := Right;
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.
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.
160 if Exp rem 2 /= 0 then
162 pragma Unsuppress (All_Checks);
164 Result := Result * Factor;
172 pragma Unsuppress (All_Checks);
174 Factor := Factor * Factor;
180 end Exp_Integer_Type;