File : s-fatgen.adb
------------------------------------------------------------------------------
-- --
-- GNAT COMPILER COMPONENTS --
-- --
5 -- S Y S T E M . F A T _ G E N --
-- --
-- B o d y --
-- --
-- $Revision: 1.21.2.1 $
10 -- --
-- Copyright (C) 1992-2002 Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
15 -- ware Foundation; either version 2, or (at your option) any later ver- --
-- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
-- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
20 -- Public License distributed with GNAT; see file COPYING. If not, write --
-- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
-- MA 02111-1307, USA. --
-- --
-- As a special exception, if other files instantiate generics from this --
25 -- unit, or you link this unit with other files to produce an executable, --
-- this unit does not by itself cause the resulting executable to be --
-- covered by the GNU General Public License. This exception does not --
-- however invalidate any other reasons why the executable file might be --
-- covered by the GNU Public License. --
30 -- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
-- --
------------------------------------------------------------------------------
35
-- The implementation here is portable to any IEEE implementation. It does
-- not handle non-binary radix, and also assumes that model numbers and
-- machine numbers are basically identical, which is not true of all possible
-- floating-point implementations. On a non-IEEE machine, this body must be
40 -- specialized appropriately, or better still, its generic instantiations
-- should be replaced by efficient machine-specific code.
with Ada.Unchecked_Conversion;
with System;
45 package body System.Fat_Gen is
Float_Radix : constant T := T (T'Machine_Radix);
Float_Radix_Inv : constant T := 1.0 / Float_Radix;
Radix_To_M_Minus_1 : constant T := Float_Radix ** (T'Machine_Mantissa - 1);
50
pragma Assert (T'Machine_Radix = 2);
-- This version does not handle radix 16
-- Constants for Decompose and Scaling
55
Rad : constant T := T (T'Machine_Radix);
Invrad : constant T := 1.0 / Rad;
subtype Expbits is Integer range 0 .. 6;
60 -- 2 ** (2 ** 7) might overflow. how big can radix-16 exponents get?
Log_Power : constant array (Expbits) of Integer := (1, 2, 4, 8, 16, 32, 64);
R_Power : constant array (Expbits) of T :=
65 (Rad ** 1,
Rad ** 2,
Rad ** 4,
Rad ** 8,
Rad ** 16,
70 Rad ** 32,
Rad ** 64);
R_Neg_Power : constant array (Expbits) of T :=
(Invrad ** 1,
75 Invrad ** 2,
Invrad ** 4,
Invrad ** 8,
Invrad ** 16,
Invrad ** 32,
80 Invrad ** 64);
-----------------------
-- Local Subprograms --
-----------------------
85
procedure Decompose (XX : T; Frac : out T; Expo : out UI);
-- Decomposes a floating-point number into fraction and exponent parts
function Gradual_Scaling (Adjustment : UI) return T;
90 -- Like Scaling with a first argument of 1.0, but returns the smallest
-- denormal rather than zero when the adjustment is smaller than
-- Machine_Emin. Used for Succ and Pred.
--------------
95 -- Adjacent --
--------------
function Adjacent (X, Towards : T) return T is
begin
100 if Towards = X then
return X;
elsif Towards > X then
return Succ (X);
105
else
return Pred (X);
end if;
end Adjacent;
110
-------------
-- Ceiling --
-------------
115 function Ceiling (X : T) return T is
XT : constant T := Truncation (X);
begin
if X <= 0.0 then
120 return XT;
elsif X = XT then
return X;
125 else
return XT + 1.0;
end if;
end Ceiling;
130 -------------
-- Compose --
-------------
function Compose (Fraction : T; Exponent : UI) return T is
135 Arg_Frac : T;
Arg_Exp : UI;
begin
Decompose (Fraction, Arg_Frac, Arg_Exp);
140 return Scaling (Arg_Frac, Exponent);
end Compose;
---------------
-- Copy_Sign --
145 ---------------
function Copy_Sign (Value, Sign : T) return T is
Result : T;
150 function Is_Negative (V : T) return Boolean;
pragma Import (Intrinsic, Is_Negative);
begin
Result := abs Value;
155
if Is_Negative (Sign) then
return -Result;
else
return Result;
160 end if;
end Copy_Sign;
---------------
-- Decompose --
165 ---------------
procedure Decompose (XX : T; Frac : out T; Expo : out UI) is
X : T := T'Machine (XX);
170 begin
if X = 0.0 then
Frac := X;
Expo := 0;
175 -- More useful would be defining Expo to be T'Machine_Emin - 1 or
-- T'Machine_Emin - T'Machine_Mantissa, which would preserve
-- monotonicity of the exponent function ???
-- Check for infinities, transfinites, whatnot.
180
elsif X > T'Safe_Last then
Frac := Invrad;
Expo := T'Machine_Emax + 1;
185 elsif X < T'Safe_First then
Frac := -Invrad;
Expo := T'Machine_Emax + 2; -- how many extra negative values?
else
190 -- Case of nonzero finite x. Essentially, we just multiply
-- by Rad ** (+-2**N) to reduce the range.
declare
Ax : T := abs X;
195 Ex : UI := 0;
-- Ax * Rad ** Ex is invariant.
begin
200 if Ax >= 1.0 then
while Ax >= R_Power (Expbits'Last) loop
Ax := Ax * R_Neg_Power (Expbits'Last);
Ex := Ex + Log_Power (Expbits'Last);
end loop;
205
-- Ax < Rad ** 64
for N in reverse Expbits'First .. Expbits'Last - 1 loop
if Ax >= R_Power (N) then
210 Ax := Ax * R_Neg_Power (N);
Ex := Ex + Log_Power (N);
end if;
-- Ax < R_Power (N)
215 end loop;
-- 1 <= Ax < Rad
Ax := Ax * Invrad;
220 Ex := Ex + 1;
else
-- 0 < ax < 1
225 while Ax < R_Neg_Power (Expbits'Last) loop
Ax := Ax * R_Power (Expbits'Last);
Ex := Ex - Log_Power (Expbits'Last);
end loop;
230 -- Rad ** -64 <= Ax < 1
for N in reverse Expbits'First .. Expbits'Last - 1 loop
if Ax < R_Neg_Power (N) then
Ax := Ax * R_Power (N);
235 Ex := Ex - Log_Power (N);
end if;
-- R_Neg_Power (N) <= Ax < 1
end loop;
240 end if;
if X > 0.0 then
Frac := Ax;
else
245 Frac := -Ax;
end if;
Expo := Ex;
end;
250 end if;
end Decompose;
--------------
-- Exponent --
255 --------------
function Exponent (X : T) return UI is
X_Frac : T;
X_Exp : UI;
260
begin
Decompose (X, X_Frac, X_Exp);
return X_Exp;
end Exponent;
265
-----------
-- Floor --
-----------
270 function Floor (X : T) return T is
XT : constant T := Truncation (X);
begin
if X >= 0.0 then
275 return XT;
elsif XT = X then
return X;
280 else
return XT - 1.0;
end if;
end Floor;
285 --------------
-- Fraction --
--------------
function Fraction (X : T) return T is
290 X_Frac : T;
X_Exp : UI;
begin
Decompose (X, X_Frac, X_Exp);
295 return X_Frac;
end Fraction;
---------------------
-- Gradual_Scaling --
300 ---------------------
function Gradual_Scaling (Adjustment : UI) return T is
Y : T;
Y1 : T;
305 Ex : UI := Adjustment;
begin
if Adjustment < T'Machine_Emin then
Y := 2.0 ** T'Machine_Emin;
310 Y1 := Y;
Ex := Ex - T'Machine_Emin;
while Ex <= 0 loop
Y := T'Machine (Y / 2.0);
315
if Y = 0.0 then
return Y1;
end if;
320 Ex := Ex + 1;
Y1 := Y;
end loop;
return Y1;
325
else
return Scaling (1.0, Adjustment);
end if;
end Gradual_Scaling;
330
------------------
-- Leading_Part --
------------------
335 function Leading_Part (X : T; Radix_Digits : UI) return T is
L : UI;
Y, Z : T;
begin
340 if Radix_Digits >= T'Machine_Mantissa then
return X;
else
L := Exponent (X) - Radix_Digits;
345 Y := Truncation (Scaling (X, -L));
Z := Scaling (Y, L);
return Z;
end if;
350 end Leading_Part;
-------------
-- Machine --
-------------
355
-- The trick with Machine is to force the compiler to store the result
-- in memory so that we do not have extra precision used. The compiler
-- is clever, so we have to outwit its possible optimizations! We do
-- this by using an intermediate pragma Volatile location.
360
function Machine (X : T) return T is
Temp : T;
pragma Volatile (Temp);
365 begin
Temp := X;
return Temp;
end Machine;
370 -----------
-- Model --
-----------
-- We treat Model as identical to Machine. This is true of IEEE and other
375 -- nice floating-point systems, but not necessarily true of all systems.
function Model (X : T) return T is
begin
return Machine (X);
380 end Model;
----------
-- Pred --
----------
385
-- Subtract from the given number a number equivalent to the value of its
-- least significant bit. Given that the most significant bit represents
-- a value of 1.0 * radix ** (exp - 1), the value we want is obtained by
-- shifting this by (mantissa-1) bits to the right, i.e. decreasing the
390 -- exponent by that amount.
-- Zero has to be treated specially, since its exponent is zero
function Pred (X : T) return T is
395 X_Frac : T;
X_Exp : UI;
begin
if X = 0.0 then
400 return -Succ (X);
else
Decompose (X, X_Frac, X_Exp);
405 -- A special case, if the number we had was a positive power of
-- two, then we want to subtract half of what we would otherwise
-- subtract, since the exponent is going to be reduced.
if X_Frac = 0.5 and then X > 0.0 then
410 return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1);
-- Otherwise the exponent stays the same
else
415 return X - Gradual_Scaling (X_Exp - T'Machine_Mantissa);
end if;
end if;
end Pred;
420 ---------------
-- Remainder --
---------------
function Remainder (X, Y : T) return T is
425 A : T;
B : T;
Arg : T;
P : T;
Arg_Frac : T;
430 P_Frac : T;
Sign_X : T;
IEEE_Rem : T;
Arg_Exp : UI;
P_Exp : UI;
435 K : UI;
P_Even : Boolean;
begin
if X > 0.0 then
440 Sign_X := 1.0;
Arg := X;
else
Sign_X := -1.0;
Arg := -X;
445 end if;
P := abs Y;
if Arg < P then
450 P_Even := True;
IEEE_Rem := Arg;
P_Exp := Exponent (P);
else
455 Decompose (Arg, Arg_Frac, Arg_Exp);
Decompose (P, P_Frac, P_Exp);
P := Compose (P_Frac, Arg_Exp);
K := Arg_Exp - P_Exp;
460 P_Even := True;
IEEE_Rem := Arg;
for Cnt in reverse 0 .. K loop
if IEEE_Rem >= P then
465 P_Even := False;
IEEE_Rem := IEEE_Rem - P;
else
P_Even := True;
end if;
470
P := P * 0.5;
end loop;
end if;
475 -- That completes the calculation of modulus remainder. The final
-- step is get the IEEE remainder. Here we need to compare Rem with
-- (abs Y) / 2. We must be careful of unrepresentable Y/2 value
-- caused by subnormal numbers
480 if P_Exp >= 0 then
A := IEEE_Rem;
B := abs Y * 0.5;
else
485 A := IEEE_Rem * 2.0;
B := abs Y;
end if;
if A > B or else (A = B and then not P_Even) then
490 IEEE_Rem := IEEE_Rem - abs Y;
end if;
return Sign_X * IEEE_Rem;
495 end Remainder;
--------------
-- Rounding --
--------------
500
function Rounding (X : T) return T is
Result : T;
Tail : T;
505 begin
Result := Truncation (abs X);
Tail := abs X - Result;
if Tail >= 0.5 then
510 Result := Result + 1.0;
end if;
if X > 0.0 then
return Result;
515
elsif X < 0.0 then
return -Result;
-- For zero case, make sure sign of zero is preserved
520
else
return X;
end if;
525 end Rounding;
-------------
-- Scaling --
-------------
530
-- Return x * rad ** adjustment quickly,
-- or quietly underflow to zero, or overflow naturally.
function Scaling (X : T; Adjustment : UI) return T is
535 begin
if X = 0.0 or else Adjustment = 0 then
return X;
end if;
540 -- Nonzero x. essentially, just multiply repeatedly by Rad ** (+-2**n).
declare
Y : T := X;
Ex : UI := Adjustment;
545
-- Y * Rad ** Ex is invariant
begin
if Ex < 0 then
550 while Ex <= -Log_Power (Expbits'Last) loop
Y := Y * R_Neg_Power (Expbits'Last);
Ex := Ex + Log_Power (Expbits'Last);
end loop;
555 -- -64 < Ex <= 0
for N in reverse Expbits'First .. Expbits'Last - 1 loop
if Ex <= -Log_Power (N) then
Y := Y * R_Neg_Power (N);
560 Ex := Ex + Log_Power (N);
end if;
-- -Log_Power (N) < Ex <= 0
end loop;
565
-- Ex = 0
else
-- Ex >= 0
570
while Ex >= Log_Power (Expbits'Last) loop
Y := Y * R_Power (Expbits'Last);
Ex := Ex - Log_Power (Expbits'Last);
end loop;
575
-- 0 <= Ex < 64
for N in reverse Expbits'First .. Expbits'Last - 1 loop
if Ex >= Log_Power (N) then
580 Y := Y * R_Power (N);
Ex := Ex - Log_Power (N);
end if;
-- 0 <= Ex < Log_Power (N)
585 end loop;
-- Ex = 0
end if;
return Y;
590 end;
end Scaling;
----------
-- Succ --
595 ----------
-- Similar computation to that of Pred: find value of least significant
-- bit of given number, and add. Zero has to be treated specially since
-- the exponent can be zero, and also we want the smallest denormal if
600 -- denormals are supported.
function Succ (X : T) return T is
X_Frac : T;
X_Exp : UI;
605 X1, X2 : T;
begin
if X = 0.0 then
X1 := 2.0 ** T'Machine_Emin;
610
-- Following loop generates smallest denormal
loop
X2 := T'Machine (X1 / 2.0);
615 exit when X2 = 0.0;
X1 := X2;
end loop;
return X1;
620
else
Decompose (X, X_Frac, X_Exp);
-- A special case, if the number we had was a negative power of
625 -- two, then we want to add half of what we would otherwise add,
-- since the exponent is going to be reduced.
if X_Frac = 0.5 and then X < 0.0 then
return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa - 1);
630
-- Otherwise the exponent stays the same
else
return X + Gradual_Scaling (X_Exp - T'Machine_Mantissa);
635 end if;
end if;
end Succ;
----------------
640 -- Truncation --
----------------
-- The basic approach is to compute
645 -- T'Machine (RM1 + N) - RM1.
-- where N >= 0.0 and RM1 = radix ** (mantissa - 1)
-- This works provided that the intermediate result (RM1 + N) does not
650 -- have extra precision (which is why we call Machine). When we compute
-- RM1 + N, the exponent of N will be normalized and the mantissa shifted
-- shifted appropriately so the lower order bits, which cannot contribute
-- to the integer part of N, fall off on the right. When we subtract RM1
-- again, the significant bits of N are shifted to the left, and what we
655 -- have is an integer, because only the first e bits are different from
-- zero (assuming binary radix here).
function Truncation (X : T) return T is
Result : T;
660
begin
Result := abs X;
if Result >= Radix_To_M_Minus_1 then
665 return Machine (X);
else
Result := Machine (Radix_To_M_Minus_1 + Result) - Radix_To_M_Minus_1;
670 if Result > abs X then
Result := Result - 1.0;
end if;
if X > 0.0 then
675 return Result;
elsif X < 0.0 then
return -Result;
680 -- For zero case, make sure sign of zero is preserved
else
return X;
end if;
685 end if;
end Truncation;
-----------------------
690 -- Unbiased_Rounding --
-----------------------
function Unbiased_Rounding (X : T) return T is
Abs_X : constant T := abs X;
695 Result : T;
Tail : T;
begin
Result := Truncation (Abs_X);
700 Tail := Abs_X - Result;
if Tail > 0.5 then
Result := Result + 1.0;
705 elsif Tail = 0.5 then
Result := 2.0 * Truncation ((Result / 2.0) + 0.5);
end if;
if X > 0.0 then
710 return Result;
elsif X < 0.0 then
return -Result;
715 -- For zero case, make sure sign of zero is preserved
else
return X;
end if;
720
end Unbiased_Rounding;
-----------
-- Valid --
725 -----------
function Valid (X : access T) return Boolean is
IEEE_Emin : constant Integer := T'Machine_Emin - 1;
730 IEEE_Emax : constant Integer := T'Machine_Emax - 1;
IEEE_Bias : constant Integer := -(IEEE_Emin - 1);
subtype IEEE_Exponent_Range is
735 Integer range IEEE_Emin - 1 .. IEEE_Emax + 1;
-- The implementation of this floating point attribute uses
-- a representation type Float_Rep that allows direct access to
-- the exponent and mantissa parts of a floating point number.
740
-- The Float_Rep type is an array of Float_Word elements. This
-- representation is chosen to make it possible to size the
-- type based on a generic parameter.
745 -- The following conditions must be met for all possible
-- instantiations of the attributes package:
-- - T'Size is an integral multiple of Float_Word'Size
750 -- - The exponent and sign are completely contained in a single
-- component of Float_Rep, named Most_Significant_Word (MSW).
-- - The sign occupies the most significant bit of the MSW
-- and the exponent is in the following bits.
755 -- Unused bits (if any) are in the least significant part.
type Float_Word is mod 2**32;
type Rep_Index is range 0 .. 7;
760 Rep_Last : constant Rep_Index := (T'Size - 1) / Float_Word'Size;
type Float_Rep is array (Rep_Index range 0 .. Rep_Last) of Float_Word;
pragma Suppress_Initialization (Float_Rep);
765 -- This pragma supresses the generation of an initialization procedure
-- for type Float_Rep when operating in Initialize/Normalize_Scalars
-- mode. This is not just a matter of efficiency, but of functionality,
-- since Valid has a pragma Inline_Always, which is not permitted if
-- there are nested subprograms present.
770
Most_Significant_Word : constant Rep_Index :=
Rep_Last * Standard'Default_Bit_Order;
-- Finding the location of the Exponent_Word is a bit tricky.
-- In general we assume Word_Order = Bit_Order.
775 -- This expression needs to be refined for VMS.
Exponent_Factor : constant Float_Word :=
2**(Float_Word'Size - 1) /
Float_Word (IEEE_Emax - IEEE_Emin + 3) *
780 Boolean'Pos (T'Size /= 96) +
Boolean'Pos (T'Size = 96);
-- Factor that the extracted exponent needs to be divided by
-- to be in range 0 .. IEEE_Emax - IEEE_Emin + 2.
-- Special kludge: Exponent_Factor is 0 for x86 double extended
785 -- as GCC adds 16 unused bits to the type.
Exponent_Mask : constant Float_Word :=
Float_Word (IEEE_Emax - IEEE_Emin + 2) *
Exponent_Factor;
790 -- Value needed to mask out the exponent field.
-- This assumes that the range IEEE_Emin - 1 .. IEEE_Emax + 1
-- contains 2**N values, for some N in Natural.
function To_Float is new Ada.Unchecked_Conversion (Float_Rep, T);
795
type Float_Access is access all T;
function To_Address is
new Ada.Unchecked_Conversion (Float_Access, System.Address);
800 XA : constant System.Address := To_Address (Float_Access (X));
R : Float_Rep;
pragma Import (Ada, R);
for R'Address use XA;
805 -- R is a view of the input floating-point parameter. Note that we
-- must avoid copying the actual bits of this parameter in float
-- form (since it may be a signalling NaN.
E : constant IEEE_Exponent_Range :=
810 Integer ((R (Most_Significant_Word) and Exponent_Mask) /
Exponent_Factor)
- IEEE_Bias;
-- Mask/Shift T to only get bits from the exponent
-- Then convert biased value to integer value.
815
SR : Float_Rep;
-- Float_Rep representation of significant of X.all
begin
820 if T'Denorm then
-- All denormalized numbers are valid, so only invalid numbers
-- are overflows and NaN's, both with exponent = Emax + 1.
825 return E /= IEEE_Emax + 1;
end if;
-- All denormalized numbers except 0.0 are invalid
830
-- Set exponent of X to zero, so we end up with the significand, which
-- definitely is a valid number and can be converted back to a float.
SR := R;
835 SR (Most_Significant_Word) :=
(SR (Most_Significant_Word)
and not Exponent_Mask) + Float_Word (IEEE_Bias) * Exponent_Factor;
return (E in IEEE_Emin .. IEEE_Emax) or else
840 ((E = IEEE_Emin - 1) and then abs To_Float (SR) = 1.0);
end Valid;
end System.Fat_Gen;