===================================================================
@@ -1,204 +0,0 @@
-------------------------------------------------------------------------------
-------------------------------------------------------------------------------
-
-
-
-
-package Ttypef is
-
- ----------------------------------
- -- Universal Integer Attributes --
- ----------------------------------
-
- -- Note that the constant declarations below specify values
- -- using the Ada model, so IEEES_Machine_Emax does not specify
- -- the IEEE definition of the single precision float type,
- -- but the value of the Ada attribute which is one higher
- -- as the binary point is at a different location.
-
- IEEES_Digits : constant := 6;
- IEEEL_Digits : constant := 15;
- IEEEX_Digits : constant := 18;
- VAXFF_Digits : constant := 6;
- VAXDF_Digits : constant := 9;
- VAXGF_Digits : constant := 15;
- AAMPS_Digits : constant := 6;
- AAMPL_Digits : constant := 9;
-
- IEEES_Machine_Emax : constant := 128;
- IEEEL_Machine_Emax : constant := 1024;
- IEEEX_Machine_Emax : constant := 16384;
- VAXFF_Machine_Emax : constant := 127;
- VAXDF_Machine_Emax : constant := 127;
- VAXGF_Machine_Emax : constant := 1023;
- AAMPS_Machine_Emax : constant := 127;
- AAMPL_Machine_Emax : constant := 127;
-
- IEEES_Machine_Emin : constant := -125;
- IEEEL_Machine_Emin : constant := -1021;
- IEEEX_Machine_Emin : constant := -16381;
- VAXFF_Machine_Emin : constant := -127;
- VAXDF_Machine_Emin : constant := -127;
- VAXGF_Machine_Emin : constant := -1023;
- AAMPS_Machine_Emin : constant := -127;
- AAMPL_Machine_Emin : constant := -127;
-
- IEEES_Machine_Mantissa : constant := 24;
- IEEEL_Machine_Mantissa : constant := 53;
- IEEEX_Machine_Mantissa : constant := 64;
- VAXFF_Machine_Mantissa : constant := 24;
- VAXDF_Machine_Mantissa : constant := 56;
- VAXGF_Machine_Mantissa : constant := 53;
- AAMPS_Machine_Mantissa : constant := 24;
- AAMPL_Machine_Mantissa : constant := 40;
-
- IEEES_Model_Emin : constant := -125;
- IEEEL_Model_Emin : constant := -1021;
- IEEEX_Model_Emin : constant := -16381;
- VAXFF_Model_Emin : constant := -127;
- VAXDF_Model_Emin : constant := -127;
- VAXGF_Model_Emin : constant := -1023;
- AAMPS_Model_Emin : constant := -127;
- AAMPL_Model_Emin : constant := -127;
-
- IEEES_Model_Mantissa : constant := 24;
- IEEEL_Model_Mantissa : constant := 53;
- IEEEX_Model_Mantissa : constant := 64;
- VAXFF_Model_Mantissa : constant := 24;
- VAXDF_Model_Mantissa : constant := 56;
- VAXGF_Model_Mantissa : constant := 53;
- AAMPS_Model_Mantissa : constant := 24;
- AAMPL_Model_Mantissa : constant := 40;
-
- IEEES_Safe_Emax : constant := 128;
- IEEEL_Safe_Emax : constant := 1024;
- IEEEX_Safe_Emax : constant := 16384;
- VAXFF_Safe_Emax : constant := 127;
- VAXDF_Safe_Emax : constant := 127;
- VAXGF_Safe_Emax : constant := 1023;
- AAMPS_Safe_Emax : constant := 127;
- AAMPL_Safe_Emax : constant := 127;
-
- -------------------------------
- -- Universal Real Attributes --
- -------------------------------
-
- IEEES_Model_Epsilon : constant := 2#1.0#E-23;
- IEEEL_Model_Epsilon : constant := 2#1.0#E-52;
- IEEEX_Model_Epsilon : constant := 2#1.0#E-63;
- VAXFF_Model_Epsilon : constant := 2#1.0#E-23;
- VAXDF_Model_Epsilon : constant := 2#1.0#E-55;
- VAXGF_Model_Epsilon : constant := 2#1.0#E-52;
- AAMPS_Model_Epsilon : constant := 2#1.0#E-23;
- AAMPL_Model_Epsilon : constant := 2#1.0#E-39;
-
- IEEES_Model_Small : constant := 2#1.0#E-126;
- IEEEL_Model_Small : constant := 2#1.0#E-1022;
- IEEEX_Model_Small : constant := 2#1.0#E-16382;
- VAXFF_Model_Small : constant := 2#1.0#E-128;
- VAXDF_Model_Small : constant := 2#1.0#E-128;
- VAXGF_Model_Small : constant := 2#1.0#E-1024;
- AAMPS_Model_Small : constant := 2#1.0#E-128;
- AAMPL_Model_Small : constant := 2#1.0#E-128;
-
- IEEES_Safe_First : constant := -16#0.FFFF_FF#E+32;
- IEEEL_Safe_First : constant := -16#0.FFFF_FFFF_FFFF_F8#E+256;
- IEEEX_Safe_First : constant := -16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
- VAXFF_Safe_First : constant := -16#0.7FFF_FF8#E+32;
- VAXDF_Safe_First : constant := -16#0.7FFF_FFFF_FFFF_FF8#E+32;
- VAXGF_Safe_First : constant := -16#0.7FFF_FFFF_FFFF_FC#E+256;
- AAMPS_Safe_First : constant := -16#0.7FFF_FF8#E+32;
- AAMPL_Safe_First : constant := -16#0.7FFF_FFFF_FF8#E+32;
-
- IEEES_Safe_Large : constant := 16#0.FFFF_FF#E+32;
- IEEEL_Safe_Large : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256;
- IEEEX_Safe_Large : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
- VAXFF_Safe_Large : constant := 16#0.7FFF_FF8#E+32;
- VAXDF_Safe_Large : constant := 16#0.7FFF_FFFF_FFFF_FF8#E+32;
- VAXGF_Safe_Large : constant := 16#0.7FFF_FFFF_FFFF_FC#E+256;
- AAMPS_Safe_Large : constant := 16#0.7FFF_FF8#E+32;
- AAMPL_Safe_Large : constant := 16#0.7FFF_FFFF_FF8#E+32;
-
- IEEES_Safe_Last : constant := 16#0.FFFF_FF#E+32;
- IEEEL_Safe_Last : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256;
- IEEEX_Safe_Last : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
- VAXFF_Safe_Last : constant := 16#0.7FFF_FF8#E+32;
- VAXDF_Safe_Last : constant := 16#0.7FFF_FFFF_FFFF_FF8#E+32;
- VAXGF_Safe_Last : constant := 16#0.7FFF_FFFF_FFFF_FC#E+256;
- AAMPS_Safe_Last : constant := 16#0.7FFF_FF8#E+32;
- AAMPL_Safe_Last : constant := 16#0.7FFF_FFFF_FF8#E+32;
-
- IEEES_Safe_Small : constant := 2#1.0#E-126;
- IEEEL_Safe_Small : constant := 2#1.0#E-1022;
- IEEEX_Safe_Small : constant := 2#1.0#E-16382;
- VAXFF_Safe_Small : constant := 2#1.0#E-128;
- VAXDF_Safe_Small : constant := 2#1.0#E-128;
- VAXGF_Safe_Small : constant := 2#1.0#E-1024;
- AAMPS_Safe_Small : constant := 2#1.0#E-128;
- AAMPL_Safe_Small : constant := 2#1.0#E-128;
-
- ----------------------
- -- Typed Attributes --
- ----------------------
-
- -- The attributes First and Last are typed attributes in Ada, and yield
- -- values of the appropriate float type. However we still describe them
- -- as universal real values in this file, since we are talking about the
- -- target floating-point types, not the host floating-point types.
-
- IEEES_First : constant := -16#0.FFFF_FF#E+32;
- IEEEL_First : constant := -16#0.FFFF_FFFF_FFFF_F8#E+256;
- IEEEX_First : constant := -16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
- VAXFF_First : constant := -16#0.7FFF_FF8#E+32;
- VAXDF_First : constant := -16#0.7FFF_FFFF_FFFF_FF8#E+32;
- VAXGF_First : constant := -16#0.7FFF_FFFF_FFFF_FC#E+256;
- AAMPS_First : constant := -16#0.7FFF_FF8#E+32;
- AAMPL_First : constant := -16#0.7FFF_FFFF_FF8#E+32;
-
- IEEES_Last : constant := 16#0.FFFF_FF#E+32;
- IEEEL_Last : constant := 16#0.FFFF_FFFF_FFFF_F8#E+256;
- IEEEX_Last : constant := 16#0.FFFF_FFFF_FFFF_FFFF#E+4096;
- VAXFF_Last : constant := 16#0.7FFF_FF8#E+32;
- VAXDF_Last : constant := 16#0.7FFF_FFFF_FFFF_FF8#E+32;
- VAXGF_Last : constant := 16#0.7FFF_FFFF_FFFF_FC#E+256;
- AAMPS_Last : constant := 16#0.7FFF_FF8#E+32;
- AAMPL_Last : constant := 16#0.7FFF_FFFF_FF8#E+32;
-
-end Ttypef;
===================================================================
@@ -6450,9 +6450,7 @@ number. The static result is the string
the number as defined in the original source. This allows the user
program to access the actual text of named numbers without intermediate
conversions and without the need to enclose the strings in quotes (which
-would preclude their use as numbers). This is used internally for the
-construction of values of the floating-point attributes from the file
-@file{ttypef.ads}, but may also be used by user programs.
+would preclude their use as numbers).
For example, the following program prints the first 50 digits of pi:
@@ -9181,8 +9179,8 @@ random numbers is one microsecond.
Annex is not supported. See A.5.3(72).
@end cartouche
@noindent
-See the source file @file{ttypef.ads} for the values of all numeric
-attributes.
+Run the compiler with @option{-gnatS} to produce a listing of package
+@code{Standard}, has the values of all numeric attributes.
@sp 1
@cartouche
===================================================================
@@ -32,11 +32,12 @@
pragma Style_Checks (All_Checks);
-- Turn off subprogram ordering, not used for this unit
-with Atree; use Atree;
-with Nlists; use Nlists;
-with Output; use Output;
-with Sinfo; use Sinfo;
-with Stand; use Stand;
+with Atree; use Atree;
+with Nlists; use Nlists;
+with Output; use Output;
+with Sinfo; use Sinfo;
+with Stand; use Stand;
+with Targparm; use Targparm;
package body Einfo is
@@ -520,6 +521,12 @@ package body Einfo is
-- (unused) Flag253
-- (unused) Flag254
+ -----------------
+ -- Local types --
+ -----------------
+
+ type Float_Rep_Kind is (IEEE_Binary, VAX_Native, AAMP);
+
-----------------------
-- Local subprograms --
-----------------------
@@ -528,6 +535,25 @@ package body Einfo is
-- Returns the attribute definition clause for Id whose name is Rep_Name.
-- Returns Empty if no matching attribute definition clause found for Id.
+ function Float_Rep (Id : E) return Float_Rep_Kind;
+ -- Returns the floating point representation used for the given type
+
+ ---------------
+ -- Float_Rep --
+ ---------------
+
+ function Float_Rep (Id : E) return Float_Rep_Kind is
+ pragma Assert (Is_Floating_Point_Type (Id));
+ begin
+ if AAMP_On_Target then
+ return AAMP;
+ elsif Vax_Float (Id) then
+ return VAX_Native;
+ else
+ return IEEE_Binary;
+ end if;
+ end Float_Rep;
+
----------------
-- Rep_Clause --
----------------
@@ -2185,12 +2211,84 @@ package body Einfo is
return Flag205 (Id);
end Low_Bound_Tested;
+ function Machine_Emax_Value (Id : E) return Uint is
+ Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
+
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary =>
+ case Digs is
+ when 1 .. 6 => return Uint_128;
+ when 7 .. 15 => return 2**10;
+ when 16 .. 18 => return 2**14;
+ when others => return No_Uint;
+ end case;
+
+ when VAX_Native =>
+ case Digs is
+ when 1 .. 9 => return 2**7 - 1;
+ when 10 .. 15 => return 2**10 - 1;
+ when others => return No_Uint;
+ end case;
+
+ when AAMP =>
+ return Uint_2 ** Uint_7 - Uint_1;
+ end case;
+ end Machine_Emax_Value;
+
+ function Machine_Emin_Value (Id : E) return Uint is
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary => return Uint_3 - Machine_Emax_Value (Id);
+ when VAX_Native => return -Machine_Emax_Value (Id);
+ when AAMP => return -Machine_Emax_Value (Id);
+ end case;
+ end Machine_Emin_Value;
+
+ function Machine_Mantissa_Value (Id : E) return Uint is
+ Digs : constant Pos := UI_To_Int (Digits_Value (Base_Type (Id)));
+
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary =>
+ case Digs is
+ when 1 .. 6 => return Uint_24;
+ when 7 .. 15 => return UI_From_Int (53);
+ when 16 .. 18 => return Uint_64;
+ when others => return No_Uint;
+ end case;
+
+ when VAX_Native =>
+ case Digs is
+ when 1 .. 6 => return Uint_24;
+ when 7 .. 9 => return UI_From_Int (56);
+ when 10 .. 15 => return UI_From_Int (53);
+ when others => return No_Uint;
+ end case;
+
+ when AAMP =>
+ case Digs is
+ when 1 .. 6 => return Uint_24;
+ when 7 .. 9 => return UI_From_Int (40);
+ when others => return No_Uint;
+ end case;
+ end case;
+ end Machine_Mantissa_Value;
+
function Machine_Radix_10 (Id : E) return B is
begin
pragma Assert (Is_Decimal_Fixed_Point_Type (Id));
return Flag84 (Id);
end Machine_Radix_10;
+ function Machine_Radix_Value (Id : E) return U is
+ begin
+ case Float_Rep (Id) is
+ when IEEE_Binary | VAX_Native | AAMP =>
+ return Uint_2;
+ end case;
+ end Machine_Radix_Value;
+
function Master_Id (Id : E) return E is
begin
pragma Assert (Is_Access_Type (Id));
@@ -2208,6 +2306,28 @@ package body Einfo is
return UI_To_Int (Uint8 (Id));
end Mechanism;
+ function Model_Emin_Value (Id : E) return Uint is
+ begin
+ return Machine_Emin_Value (Id);
+ end Model_Emin_Value;
+
+ function Model_Epsilon_Value (Id : E) return Ureal is
+ Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
+ begin
+ return Radix ** (1 - Model_Mantissa_Value (Id));
+ end Model_Epsilon_Value;
+
+ function Model_Mantissa_Value (Id : E) return Uint is
+ begin
+ return Machine_Mantissa_Value (Id);
+ end Model_Mantissa_Value;
+
+ function Model_Small_Value (Id : E) return Ureal is
+ Radix : constant Ureal := UR_From_Uint (Machine_Radix_Value (Id));
+ begin
+ return Radix ** (Model_Emin_Value (Id) - 1);
+ end Model_Small_Value;
+
function Modulus (Id : E) return Uint is
begin
pragma Assert (Is_Modular_Integer_Type (Id));
@@ -2540,6 +2660,38 @@ package body Einfo is
return Uint13 (Id);
end RM_Size;
+ function Safe_Emax_Value (Id : E) return Uint is
+ begin
+ return Machine_Emax_Value (Id);
+ end Safe_Emax_Value;
+
+ function Safe_First_Value (Id : E) return Ureal is
+ begin
+ return -Safe_Last_Value (Id);
+ end Safe_First_Value;
+
+ function Safe_Last_Value (Id : E) return Ureal is
+ Radix : constant Uint := Machine_Radix_Value (Id);
+ Mantissa : constant Uint := Machine_Mantissa_Value (Id);
+ Emax : constant Uint := Safe_Emax_Value (Id);
+ Significand : constant Uint := Radix ** Mantissa - 1;
+ Exponent : constant Uint := Emax - Mantissa;
+ begin
+ if Radix = 2 then
+ return
+ UR_From_Components
+ (Num => Significand * 2 ** (Exponent mod 4),
+ Den => -Exponent / 4,
+ Rbase => 16);
+ else
+ return
+ UR_From_Components
+ (Num => Significand,
+ Den => -Exponent,
+ Rbase => 16);
+ end if;
+ end Safe_Last_Value;
+
function Scalar_Range (Id : E) return N is
begin
return Node20 (Id);
@@ -6549,7 +6701,6 @@ package body Einfo is
-- of analyzing default expressions.
P := Id;
-
loop
P := Next_Entity (P);
===================================================================
@@ -5094,6 +5094,17 @@ package Einfo is
-- E_Floating_Point_Type
-- E_Floating_Point_Subtype
-- Digits_Value (Uint17)
+ -- Machine_Emax_Value (synth)
+ -- Machine_Emin_Value (synth)
+ -- Machine_Mantissa_Value (synth)
+ -- Machine_Radix_Value (synth)
+ -- Model_Emin_Value (synth)
+ -- Model_Epsilon_Value (synth)
+ -- Model_Mantissa_Value (synth)
+ -- Model_Small_Value (synth)
+ -- Safe_Emax_Value (synth)
+ -- Safe_First_Value (synth)
+ -- Safe_Last_Value (synth)
-- Scalar_Range (Node20)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
@@ -6334,6 +6345,14 @@ package Einfo is
function Is_Task_Record_Type (Id : E) return B;
function Is_Wrapper_Package (Id : E) return B;
function Last_Formal (Id : E) return E;
+ function Machine_Emax_Value (Id : E) return U;
+ function Machine_Emin_Value (Id : E) return U;
+ function Machine_Mantissa_Value (Id : E) return U;
+ function Machine_Radix_Value (Id : E) return U;
+ function Model_Emin_Value (Id : E) return U;
+ function Model_Epsilon_Value (Id : E) return R;
+ function Model_Mantissa_Value (Id : E) return U;
+ function Model_Small_Value (Id : E) return R;
function Next_Component (Id : E) return E;
function Next_Component_Or_Discriminant (Id : E) return E;
function Next_Discriminant (Id : E) return E;
@@ -6347,6 +6366,9 @@ package Einfo is
function Parameter_Mode (Id : E) return Formal_Kind;
function Primitive_Operations (Id : E) return L;
function Root_Type (Id : E) return E;
+ function Safe_Emax_Value (Id : E) return U;
+ function Safe_First_Value (Id : E) return R;
+ function Safe_Last_Value (Id : E) return R;
function Scope_Depth_Set (Id : E) return B;
function Size_Clause (Id : E) return N;
function Stream_Size_Clause (Id : E) return N;
===================================================================
@@ -1564,8 +1564,8 @@ package body Checks is
Truncate : constant Boolean := Float_Truncate (Par);
Max_Bound : constant Uint :=
UI_Expon
- (Machine_Radix (Expr_Type),
- Machine_Mantissa (Expr_Type) - 1) - 1;
+ (Machine_Radix_Value (Expr_Type),
+ Machine_Mantissa_Value (Expr_Type) - 1) - 1;
-- Largest bound, so bound plus or minus half is a machine number of F
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1992-2010, 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- --
@@ -25,8 +25,6 @@
with Einfo; use Einfo;
with Errout; use Errout;
-with Sem_Util; use Sem_Util;
-with Ttypef; use Ttypef;
with Targparm; use Targparm;
package body Eval_Fat is
@@ -67,13 +65,11 @@ package body Eval_Fat is
Mode : Rounding_Mode);
-- This is similar to Decompose, except that the Fraction value returned
-- is an integer representing the value Fraction * Scale, where Scale is
- -- the value (Radix ** Machine_Mantissa (RT)). The value is obtained by
- -- using biased rounding (halfway cases round away from zero), round to
- -- even, a floor operation or a ceiling operation depending on the setting
- -- of Mode (see corresponding descriptions in Urealp).
-
- function Machine_Emin (RT : R) return Int;
- -- Return value of the Machine_Emin attribute
+ -- the value (Machine_Radix_Value (RT) ** Machine_Mantissa_Value (RT)). The
+ -- value is obtained by using biased rounding (halfway cases round away
+ -- from zero), round to even, a floor operation or a ceiling operation
+ -- depending on the setting of Mode (see corresponding descriptions in
+ -- Urealp).
--------------
-- Adjacent --
@@ -155,7 +151,7 @@ package body Eval_Fat is
Fraction := UR_From_Components
(Num => Int_F,
- Den => UI_From_Int (Machine_Mantissa (RT)),
+ Den => Machine_Mantissa_Value (RT),
Rbase => Radix,
Negative => False);
@@ -192,7 +188,7 @@ package body Eval_Fat is
-- True iff Fraction is even
Most_Significant_Digit : constant UI :=
- Radix ** (Machine_Mantissa (RT) - 1);
+ Radix ** (Machine_Mantissa_Value (RT) - 1);
Uintp_Mark : Uintp.Save_Mark;
-- The code is divided into blocks that systematically release
@@ -475,7 +471,7 @@ package body Eval_Fat is
------------------
function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T is
- RD : constant UI := UI_Min (Radix_Digits, Machine_Mantissa (RT));
+ RD : constant UI := UI_Min (Radix_Digits, Machine_Mantissa_Value (RT));
L : UI;
Y : T;
begin
@@ -496,7 +492,7 @@ package body Eval_Fat is
is
X_Frac : T;
X_Exp : UI;
- Emin : constant UI := UI_From_Int (Machine_Emin (RT));
+ Emin : constant UI := Machine_Emin_Value (RT);
begin
Decompose (RT, X, X_Frac, X_Exp, Mode);
@@ -513,9 +509,8 @@ package body Eval_Fat is
if X_Exp < Emin then
declare
- Emin_Den : constant UI :=
- UI_From_Int
- (Machine_Emin (RT) - Machine_Mantissa (RT) + 1);
+ Emin_Den : constant UI := Machine_Emin_Value (RT)
+ - Machine_Mantissa_Value (RT) + Uint_1;
begin
if X_Exp < Emin_Den or not Denorm_On_Target then
if UR_Is_Negative (X) then
@@ -569,108 +564,6 @@ package body Eval_Fat is
return Scaling (RT, X_Frac, X_Exp);
end Machine;
- ------------------
- -- Machine_Emin --
- ------------------
-
- function Machine_Emin (RT : R) return Int is
- Digs : constant UI := Digits_Value (RT);
- Emin : Int;
-
- begin
- if Vax_Float (RT) then
- if Digs = VAXFF_Digits then
- Emin := VAXFF_Machine_Emin;
-
- elsif Digs = VAXDF_Digits then
- Emin := VAXDF_Machine_Emin;
-
- else
- pragma Assert (Digs = VAXGF_Digits);
- Emin := VAXGF_Machine_Emin;
- end if;
-
- elsif Is_AAMP_Float (RT) then
- if Digs = AAMPS_Digits then
- Emin := AAMPS_Machine_Emin;
-
- else
- pragma Assert (Digs = AAMPL_Digits);
- Emin := AAMPL_Machine_Emin;
- end if;
-
- else
- if Digs = IEEES_Digits then
- Emin := IEEES_Machine_Emin;
-
- elsif Digs = IEEEL_Digits then
- Emin := IEEEL_Machine_Emin;
-
- else
- pragma Assert (Digs = IEEEX_Digits);
- Emin := IEEEX_Machine_Emin;
- end if;
- end if;
-
- return Emin;
- end Machine_Emin;
-
- ----------------------
- -- Machine_Mantissa --
- ----------------------
-
- function Machine_Mantissa (RT : R) return Nat is
- Digs : constant UI := Digits_Value (RT);
- Mant : Nat;
-
- begin
- if Vax_Float (RT) then
- if Digs = VAXFF_Digits then
- Mant := VAXFF_Machine_Mantissa;
-
- elsif Digs = VAXDF_Digits then
- Mant := VAXDF_Machine_Mantissa;
-
- else
- pragma Assert (Digs = VAXGF_Digits);
- Mant := VAXGF_Machine_Mantissa;
- end if;
-
- elsif Is_AAMP_Float (RT) then
- if Digs = AAMPS_Digits then
- Mant := AAMPS_Machine_Mantissa;
-
- else
- pragma Assert (Digs = AAMPL_Digits);
- Mant := AAMPL_Machine_Mantissa;
- end if;
-
- else
- if Digs = IEEES_Digits then
- Mant := IEEES_Machine_Mantissa;
-
- elsif Digs = IEEEL_Digits then
- Mant := IEEEL_Machine_Mantissa;
-
- else
- pragma Assert (Digs = IEEEX_Digits);
- Mant := IEEEX_Machine_Mantissa;
- end if;
- end if;
-
- return Mant;
- end Machine_Mantissa;
-
- -------------------
- -- Machine_Radix --
- -------------------
-
- function Machine_Radix (RT : R) return Nat is
- pragma Warnings (Off, RT);
- begin
- return Radix;
- end Machine_Radix;
-
-----------
-- Model --
-----------
@@ -818,8 +711,8 @@ package body Eval_Fat is
----------
function Succ (RT : R; X : T) return T is
- Emin : constant UI := UI_From_Int (Machine_Emin (RT));
- Mantissa : constant UI := UI_From_Int (Machine_Mantissa (RT));
+ Emin : constant UI := Machine_Emin_Value (RT);
+ Mantissa : constant UI := Machine_Mantissa_Value (RT);
Exp : UI := UI_Max (Emin, Exponent (RT, X));
Frac : T;
New_Frac : T;
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1997-2010, 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- --
@@ -32,12 +32,15 @@ with Sem_Res; use Sem_Res;
with Sinfo; use Sinfo;
with Stand; use Stand;
with Tbuild; use Tbuild;
-with Ttypef; use Ttypef;
with Uintp; use Uintp;
with Urealp; use Urealp;
package body Exp_VFpt is
+ VAXFF_Digits : constant := 6;
+ VAXDF_Digits : constant := 9;
+ VAXGF_Digits : constant := 15;
+
----------------------
-- Expand_Vax_Arith --
----------------------
===================================================================
@@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
+-- Copyright (C) 1992-2010, 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- --
@@ -65,10 +65,6 @@ package Eval_Fat is
function Leading_Part (RT : R; X : T; Radix_Digits : UI) return T;
- function Machine_Mantissa (RT : R) return Nat;
-
- function Machine_Radix (RT : R) return Nat;
-
function Model (RT : R; X : T) return T;
function Pred (RT : R; X : T) return T;
===================================================================
@@ -36,7 +36,7 @@ with Sem_Aux; use Sem_Aux;
with Snames; use Snames;
with Stand; use Stand;
with Stringt; use Stringt;
-with Uintp; use Uintp;
+with Urealp; use Urealp;
package body Tbuild is
@@ -198,6 +198,40 @@ package body Tbuild is
New_Reference_To (First_Tag_Component (Full_Type), Loc)));
end Make_DT_Access;
+ ------------------------
+ -- Make_Float_Literal --
+ ------------------------
+
+ function Make_Float_Literal
+ (Loc : Source_Ptr;
+ Radix : Uint;
+ Significand : Uint;
+ Exponent : Uint) return Node_Id
+ is
+ begin
+ if Radix = 2 and then abs Significand /= 1 then
+ return
+ Make_Float_Literal
+ (Loc, Uint_16,
+ Significand * Radix**(Exponent mod 4),
+ Exponent / 4);
+
+ else
+ declare
+ N : constant Node_Id := New_Node (N_Real_Literal, Loc);
+
+ begin
+ Set_Realval (N,
+ UR_From_Components
+ (Num => abs Significand,
+ Den => -Exponent,
+ Rbase => UI_To_Int (Radix),
+ Negative => Significand < 0));
+ return N;
+ end;
+ end if;
+ end Make_Float_Literal;
+
-------------------------------------
-- Make_Implicit_Exception_Handler --
-------------------------------------
===================================================================
@@ -29,6 +29,7 @@
with Namet; use Namet;
with Sinfo; use Sinfo;
with Types; use Types;
+with Uintp; use Uintp;
package Tbuild is
@@ -75,6 +76,14 @@ package Tbuild is
-- Create an access to the Dispatch Table by using the Tag field of a
-- tagged record : Acc_Dt (Rec.tag).all
+ function Make_Float_Literal
+ (Loc : Source_Ptr;
+ Radix : Uint;
+ Significand : Uint;
+ Exponent : Uint) return Node_Id;
+ -- Create a real literal for the floating point expression value
+ -- Significand * Radix ** Exponent. Radix must be greater than 1.
+
function Make_Implicit_Exception_Handler
(Sloc : Source_Ptr;
Choice_Parameter : Node_Id := Empty;
===================================================================
@@ -41,8 +41,6 @@ with Nlists; use Nlists;
with Output; use Output;
with Opt; use Opt;
with Rtsfind; use Rtsfind;
-with Scans; use Scans;
-with Scn; use Scn;
with Sem; use Sem;
with Sem_Aux; use Sem_Aux;
with Sem_Attr; use Sem_Attr;
@@ -10164,45 +10162,6 @@ package body Sem_Util is
Set_Sloc (Endl, Loc);
end Process_End_Label;
- ------------------
- -- Real_Convert --
- ------------------
-
- -- We do the conversion to get the value of the real string by using
- -- the scanner, see Sinput for details on use of the internal source
- -- buffer for scanning internal strings.
-
- function Real_Convert (S : String) return Node_Id is
- Save_Src : constant Source_Buffer_Ptr := Source;
- Negative : Boolean;
-
- begin
- Source := Internal_Source_Ptr;
- Scan_Ptr := 1;
-
- for J in S'Range loop
- Source (Source_Ptr (J)) := S (J);
- end loop;
-
- Source (S'Length + 1) := EOF;
-
- if Source (Scan_Ptr) = '-' then
- Negative := True;
- Scan_Ptr := Scan_Ptr + 1;
- else
- Negative := False;
- end if;
-
- Scan;
-
- if Negative then
- Set_Realval (Token_Node, UR_Negate (Realval (Token_Node)));
- end if;
-
- Source := Save_Src;
- return Token_Node;
- end Real_Convert;
-
------------------------------------
-- References_Generic_Formal_Type --
------------------------------------
===================================================================
@@ -1096,10 +1096,6 @@ package Sem_Util is
-- parameter Ent gives the entity to which the End_Label refers,
-- and to which cross-references are to be generated.
- function Real_Convert (S : String) return Node_Id;
- -- S is a possibly signed syntactically valid real literal. The result
- -- returned is an N_Real_Literal node representing the literal value.
-
function References_Generic_Formal_Type (N : Node_Id) return Boolean;
-- Returns True if the expression Expr contains any references to a
-- generic type. This can only happen within a generic template.
===================================================================
@@ -66,7 +66,6 @@ with Style;
with Stylesw; use Stylesw;
with Targparm; use Targparm;
with Ttypes; use Ttypes;
-with Ttypef; use Ttypef;
with Tbuild; use Tbuild;
with Uintp; use Uintp;
with Urealp; use Urealp;
@@ -4922,35 +4921,6 @@ package body Sem_Attr is
-- but compile time known value given by Val. It includes the
-- necessary checks for out of range values.
- procedure Float_Attribute_Universal_Integer
- (IEEES_Val : Int;
- IEEEL_Val : Int;
- IEEEX_Val : Int;
- VAXFF_Val : Int;
- VAXDF_Val : Int;
- VAXGF_Val : Int;
- AAMPS_Val : Int;
- AAMPL_Val : Int);
- -- This procedure evaluates a float attribute with no arguments that
- -- returns a universal integer result. The parameters give the values
- -- for the possible floating-point root types. See ttypef for details.
- -- The prefix type is a float type (and is thus not a generic type).
-
- procedure Float_Attribute_Universal_Real
- (IEEES_Val : String;
- IEEEL_Val : String;
- IEEEX_Val : String;
- VAXFF_Val : String;
- VAXDF_Val : String;
- VAXGF_Val : String;
- AAMPS_Val : String;
- AAMPL_Val : String);
- -- This procedure evaluates a float attribute with no arguments that
- -- returns a universal real result. The parameters give the values
- -- required for the possible floating-point root types in string
- -- format as real literals with a possible leading minus sign.
- -- The prefix type is a float type (and is thus not a generic type).
-
function Fore_Value return Nat;
-- Computes the Fore value for the current attribute prefix, which is
-- known to be a static fixed-point type. Used by Fore and Width.
@@ -5052,103 +5022,6 @@ package body Sem_Attr is
Compile_Time_Known_Value (Type_High_Bound (Typ));
end Compile_Time_Known_Bounds;
- ---------------------------------------
- -- Float_Attribute_Universal_Integer --
- ---------------------------------------
-
- procedure Float_Attribute_Universal_Integer
- (IEEES_Val : Int;
- IEEEL_Val : Int;
- IEEEX_Val : Int;
- VAXFF_Val : Int;
- VAXDF_Val : Int;
- VAXGF_Val : Int;
- AAMPS_Val : Int;
- AAMPL_Val : Int)
- is
- Val : Int;
- Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
-
- begin
- if Vax_Float (P_Base_Type) then
- if Digs = VAXFF_Digits then
- Val := VAXFF_Val;
- elsif Digs = VAXDF_Digits then
- Val := VAXDF_Val;
- else pragma Assert (Digs = VAXGF_Digits);
- Val := VAXGF_Val;
- end if;
-
- elsif Is_AAMP_Float (P_Base_Type) then
- if Digs = AAMPS_Digits then
- Val := AAMPS_Val;
- else pragma Assert (Digs = AAMPL_Digits);
- Val := AAMPL_Val;
- end if;
-
- else
- if Digs = IEEES_Digits then
- Val := IEEES_Val;
- elsif Digs = IEEEL_Digits then
- Val := IEEEL_Val;
- else pragma Assert (Digs = IEEEX_Digits);
- Val := IEEEX_Val;
- end if;
- end if;
-
- Fold_Uint (N, UI_From_Int (Val), True);
- end Float_Attribute_Universal_Integer;
-
- ------------------------------------
- -- Float_Attribute_Universal_Real --
- ------------------------------------
-
- procedure Float_Attribute_Universal_Real
- (IEEES_Val : String;
- IEEEL_Val : String;
- IEEEX_Val : String;
- VAXFF_Val : String;
- VAXDF_Val : String;
- VAXGF_Val : String;
- AAMPS_Val : String;
- AAMPL_Val : String)
- is
- Val : Node_Id;
- Digs : constant Nat := UI_To_Int (Digits_Value (P_Base_Type));
-
- begin
- if Vax_Float (P_Base_Type) then
- if Digs = VAXFF_Digits then
- Val := Real_Convert (VAXFF_Val);
- elsif Digs = VAXDF_Digits then
- Val := Real_Convert (VAXDF_Val);
- else pragma Assert (Digs = VAXGF_Digits);
- Val := Real_Convert (VAXGF_Val);
- end if;
-
- elsif Is_AAMP_Float (P_Base_Type) then
- if Digs = AAMPS_Digits then
- Val := Real_Convert (AAMPS_Val);
- else pragma Assert (Digs = AAMPL_Digits);
- Val := Real_Convert (AAMPL_Val);
- end if;
-
- else
- if Digs = IEEES_Digits then
- Val := Real_Convert (IEEES_Val);
- elsif Digs = IEEEL_Digits then
- Val := Real_Convert (IEEEL_Val);
- else pragma Assert (Digs = IEEEX_Digits);
- Val := Real_Convert (IEEEX_Val);
- end if;
- end if;
-
- Set_Sloc (Val, Loc);
- Rewrite (N, Val);
- Set_Is_Static_Expression (N, Static);
- Analyze_And_Resolve (N, C_Type);
- end Float_Attribute_Universal_Real;
-
----------------
-- Fore_Value --
----------------
@@ -6402,45 +6275,21 @@ package body Sem_Attr is
------------------
when Attribute_Machine_Emax =>
- Float_Attribute_Universal_Integer (
- IEEES_Machine_Emax,
- IEEEL_Machine_Emax,
- IEEEX_Machine_Emax,
- VAXFF_Machine_Emax,
- VAXDF_Machine_Emax,
- VAXGF_Machine_Emax,
- AAMPS_Machine_Emax,
- AAMPL_Machine_Emax);
+ Fold_Uint (N, Machine_Emax_Value (P_Type), Static);
------------------
-- Machine_Emin --
------------------
when Attribute_Machine_Emin =>
- Float_Attribute_Universal_Integer (
- IEEES_Machine_Emin,
- IEEEL_Machine_Emin,
- IEEEX_Machine_Emin,
- VAXFF_Machine_Emin,
- VAXDF_Machine_Emin,
- VAXGF_Machine_Emin,
- AAMPS_Machine_Emin,
- AAMPL_Machine_Emin);
+ Fold_Uint (N, Machine_Emin_Value (P_Type), Static);
----------------------
-- Machine_Mantissa --
----------------------
when Attribute_Machine_Mantissa =>
- Float_Attribute_Universal_Integer (
- IEEES_Machine_Mantissa,
- IEEEL_Machine_Mantissa,
- IEEEX_Machine_Mantissa,
- VAXFF_Machine_Mantissa,
- VAXDF_Machine_Mantissa,
- VAXGF_Machine_Mantissa,
- AAMPS_Machine_Mantissa,
- AAMPL_Machine_Mantissa);
+ Fold_Uint (N, Machine_Mantissa_Value (P_Type), Static);
-----------------------
-- Machine_Overflows --
@@ -6731,60 +6580,28 @@ package body Sem_Attr is
----------------
when Attribute_Model_Emin =>
- Float_Attribute_Universal_Integer (
- IEEES_Model_Emin,
- IEEEL_Model_Emin,
- IEEEX_Model_Emin,
- VAXFF_Model_Emin,
- VAXDF_Model_Emin,
- VAXGF_Model_Emin,
- AAMPS_Model_Emin,
- AAMPL_Model_Emin);
+ Fold_Uint (N, Model_Emin_Value (P_Base_Type), Static);
-------------------
-- Model_Epsilon --
-------------------
when Attribute_Model_Epsilon =>
- Float_Attribute_Universal_Real (
- IEEES_Model_Epsilon'Universal_Literal_String,
- IEEEL_Model_Epsilon'Universal_Literal_String,
- IEEEX_Model_Epsilon'Universal_Literal_String,
- VAXFF_Model_Epsilon'Universal_Literal_String,
- VAXDF_Model_Epsilon'Universal_Literal_String,
- VAXGF_Model_Epsilon'Universal_Literal_String,
- AAMPS_Model_Epsilon'Universal_Literal_String,
- AAMPL_Model_Epsilon'Universal_Literal_String);
+ Fold_Ureal (N, Model_Epsilon_Value (P_Base_Type), Static);
--------------------
-- Model_Mantissa --
--------------------
when Attribute_Model_Mantissa =>
- Float_Attribute_Universal_Integer (
- IEEES_Model_Mantissa,
- IEEEL_Model_Mantissa,
- IEEEX_Model_Mantissa,
- VAXFF_Model_Mantissa,
- VAXDF_Model_Mantissa,
- VAXGF_Model_Mantissa,
- AAMPS_Model_Mantissa,
- AAMPL_Model_Mantissa);
+ Fold_Uint (N, Model_Mantissa_Value (P_Base_Type), Static);
-----------------
-- Model_Small --
-----------------
when Attribute_Model_Small =>
- Float_Attribute_Universal_Real (
- IEEES_Model_Small'Universal_Literal_String,
- IEEEL_Model_Small'Universal_Literal_String,
- IEEEX_Model_Small'Universal_Literal_String,
- VAXFF_Model_Small'Universal_Literal_String,
- VAXDF_Model_Small'Universal_Literal_String,
- VAXGF_Model_Small'Universal_Literal_String,
- AAMPS_Model_Small'Universal_Literal_String,
- AAMPL_Model_Small'Universal_Literal_String);
+ Fold_Ureal (N, Model_Small_Value (P_Base_Type), Static);
-------------
-- Modulus --
@@ -7002,30 +6819,14 @@ package body Sem_Attr is
---------------
when Attribute_Safe_Emax =>
- Float_Attribute_Universal_Integer (
- IEEES_Safe_Emax,
- IEEEL_Safe_Emax,
- IEEEX_Safe_Emax,
- VAXFF_Safe_Emax,
- VAXDF_Safe_Emax,
- VAXGF_Safe_Emax,
- AAMPS_Safe_Emax,
- AAMPL_Safe_Emax);
+ Fold_Uint (N, Safe_Emax_Value (P_Type), Static);
----------------
-- Safe_First --
----------------
when Attribute_Safe_First =>
- Float_Attribute_Universal_Real (
- IEEES_Safe_First'Universal_Literal_String,
- IEEEL_Safe_First'Universal_Literal_String,
- IEEEX_Safe_First'Universal_Literal_String,
- VAXFF_Safe_First'Universal_Literal_String,
- VAXDF_Safe_First'Universal_Literal_String,
- VAXGF_Safe_First'Universal_Literal_String,
- AAMPS_Safe_First'Universal_Literal_String,
- AAMPL_Safe_First'Universal_Literal_String);
+ Fold_Ureal (N, Safe_First_Value (P_Type), Static);
----------------
-- Safe_Large --
@@ -7036,15 +6837,7 @@ package body Sem_Attr is
Fold_Ureal
(N, Expr_Value_R (Type_High_Bound (P_Base_Type)), Static);
else
- Float_Attribute_Universal_Real (
- IEEES_Safe_Large'Universal_Literal_String,
- IEEEL_Safe_Large'Universal_Literal_String,
- IEEEX_Safe_Large'Universal_Literal_String,
- VAXFF_Safe_Large'Universal_Literal_String,
- VAXDF_Safe_Large'Universal_Literal_String,
- VAXGF_Safe_Large'Universal_Literal_String,
- AAMPS_Safe_Large'Universal_Literal_String,
- AAMPL_Safe_Large'Universal_Literal_String);
+ Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
end if;
---------------
@@ -7052,15 +6845,7 @@ package body Sem_Attr is
---------------
when Attribute_Safe_Last =>
- Float_Attribute_Universal_Real (
- IEEES_Safe_Last'Universal_Literal_String,
- IEEEL_Safe_Last'Universal_Literal_String,
- IEEEX_Safe_Last'Universal_Literal_String,
- VAXFF_Safe_Last'Universal_Literal_String,
- VAXDF_Safe_Last'Universal_Literal_String,
- VAXGF_Safe_Last'Universal_Literal_String,
- AAMPS_Safe_Last'Universal_Literal_String,
- AAMPL_Safe_Last'Universal_Literal_String);
+ Fold_Ureal (N, Safe_Last_Value (P_Type), Static);
----------------
-- Safe_Small --
@@ -7078,15 +6863,7 @@ package body Sem_Attr is
-- Ada 83 Safe_Small for floating-point cases
else
- Float_Attribute_Universal_Real (
- IEEES_Safe_Small'Universal_Literal_String,
- IEEEL_Safe_Small'Universal_Literal_String,
- IEEEX_Safe_Small'Universal_Literal_String,
- VAXFF_Safe_Small'Universal_Literal_String,
- VAXDF_Safe_Small'Universal_Literal_String,
- VAXGF_Safe_Small'Universal_Literal_String,
- AAMPS_Safe_Small'Universal_Literal_String,
- AAMPL_Safe_Small'Universal_Literal_String);
+ Fold_Ureal (N, Model_Small_Value (P_Type), Static);
end if;
-----------
===================================================================
@@ -502,15 +502,12 @@ package Sem_Attr is
------------------------------
Attribute_Universal_Literal_String => True,
- -- The prefix of 'Universal_Literal_String must be a named number. The
- -- static result is the string consisting of the characters of the
- -- number as defined in the original source. This allows the user
- -- program to access the actual text of named numbers without
- -- intermediate conversions and without the need to enclose the strings
- -- in quotes (which would preclude their use as numbers). This is used
- -- internally for the construction of values of the floating-point
- -- attributes from the file ttypef.ads, but may also be used by user
- -- programs.
+ -- The prefix of 'Universal_Literal_String must be a named number.
+ -- The static result is the string consisting of the characters of
+ -- the number as defined in the original source. This allows the
+ -- user program to access the actual text of named numbers without
+ -- intermediate conversions and without the need to enclose the
+ -- strings in quotes (which would preclude their use as numbers).
-------------------------
-- Unrestricted_Access --
===================================================================
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
+-- Copyright (C) 1997-2010, 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- --
@@ -28,7 +28,6 @@ with Einfo; use Einfo;
with Opt; use Opt;
with Stand; use Stand;
with Targparm; use Targparm;
-with Ttypef; use Ttypef;
package body Sem_VFpt is
@@ -37,6 +36,8 @@ package body Sem_VFpt is
-----------------
procedure Set_D_Float (E : Entity_Id) is
+ VAXDF_Digits : constant := 9;
+
begin
Init_Size (Base_Type (E), 64);
Init_Alignment (Base_Type (E));
@@ -55,6 +56,8 @@ package body Sem_VFpt is
-----------------
procedure Set_F_Float (E : Entity_Id) is
+ VAXFF_Digits : constant := 6;
+
begin
Init_Size (Base_Type (E), 32);
Init_Alignment (Base_Type (E));
@@ -73,6 +76,8 @@ package body Sem_VFpt is
-----------------
procedure Set_G_Float (E : Entity_Id) is
+ VAXGF_Digits : constant := 15;
+
begin
Init_Size (Base_Type (E), 64);
Init_Alignment (Base_Type (E));
@@ -91,6 +96,8 @@ package body Sem_VFpt is
-------------------
procedure Set_IEEE_Long (E : Entity_Id) is
+ IEEEL_Digits : constant := 15;
+
begin
Init_Size (Base_Type (E), 64);
Init_Alignment (Base_Type (E));
@@ -109,6 +116,8 @@ package body Sem_VFpt is
--------------------
procedure Set_IEEE_Short (E : Entity_Id) is
+ IEEES_Digits : constant := 6;
+
begin
Init_Size (Base_Type (E), 32);
Init_Alignment (Base_Type (E));
===================================================================
@@ -36,7 +36,6 @@ with Output; use Output;
with Targparm; use Targparm;
with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
-with Ttypef; use Ttypef;
with Scn;
with Sem_Mech; use Sem_Mech;
with Sem_Util; use Sem_Util;
@@ -1670,61 +1669,11 @@ package body CStand is
-------------------
procedure P_Float_Range (Id : Entity_Id) is
- Digs : constant Nat := UI_To_Int (Digits_Value (Id));
-
begin
Write_Str (" range ");
-
- if Vax_Float (Id) then
- if Digs = VAXFF_Digits then
- Write_Str (VAXFF_First'Universal_Literal_String);
- Write_Str (" .. ");
- Write_Str (VAXFF_Last'Universal_Literal_String);
-
- elsif Digs = VAXDF_Digits then
- Write_Str (VAXDF_First'Universal_Literal_String);
- Write_Str (" .. ");
- Write_Str (VAXDF_Last'Universal_Literal_String);
-
- else
- pragma Assert (Digs = VAXGF_Digits);
-
- Write_Str (VAXGF_First'Universal_Literal_String);
- Write_Str (" .. ");
- Write_Str (VAXGF_Last'Universal_Literal_String);
- end if;
-
- elsif Is_AAMP_Float (Id) then
- if Digs = AAMPS_Digits then
- Write_Str (AAMPS_First'Universal_Literal_String);
- Write_Str (" .. ");
- Write_Str (AAMPS_Last'Universal_Literal_String);
-
- else
- pragma Assert (Digs = AAMPL_Digits);
- Write_Str (AAMPL_First'Universal_Literal_String);
- Write_Str (" .. ");
- Write_Str (AAMPL_Last'Universal_Literal_String);
- end if;
-
- elsif Digs = IEEES_Digits then
- Write_Str (IEEES_First'Universal_Literal_String);
- Write_Str (" .. ");
- Write_Str (IEEES_Last'Universal_Literal_String);
-
- elsif Digs = IEEEL_Digits then
- Write_Str (IEEEL_First'Universal_Literal_String);
- Write_Str (" .. ");
- Write_Str (IEEEL_Last'Universal_Literal_String);
-
- else
- pragma Assert (Digs = IEEEX_Digits);
-
- Write_Str (IEEEX_First'Universal_Literal_String);
- Write_Str (" .. ");
- Write_Str (IEEEX_Last'Universal_Literal_String);
- end if;
-
+ UR_Write (Realval (Type_Low_Bound (Id)));
+ Write_Str (" .. ");
+ UR_Write (Realval (Type_High_Bound (Id)));
Write_Str (";");
Write_Eol;
end P_Float_Range;
@@ -1908,81 +1857,29 @@ package body CStand is
----------------------
procedure Set_Float_Bounds (Id : Entity_Id) is
- L : Node_Id;
+ L : Node_Id;
-- Low bound of literal value
- H : Node_Id;
+ H : Node_Id;
-- High bound of literal value
- R : Node_Id;
+ R : Node_Id;
-- Range specification
- Digs : constant Nat := UI_To_Int (Digits_Value (Id));
- -- Digits value, used to select bounds
+ Radix : constant Uint := Machine_Radix_Value (Id);
+ Mantissa : constant Uint := Machine_Mantissa_Value (Id);
+ Emax : constant Uint := Machine_Emax_Value (Id);
+ Significand : constant Uint := Radix ** Mantissa - 1;
+ Exponent : constant Uint := Emax - Mantissa;
begin
-- Note: for the call from Cstand to initially create the types in
-- Standard, Vax_Float will always be False. Circuitry in Sem_Vfpt
- -- will adjust these types appropriately in the Vax_Float case if
- -- a pragma Float_Representation (VAX_Float) is used.
-
- if Vax_Float (Id) then
- if Digs = VAXFF_Digits then
- L := Real_Convert
- (VAXFF_First'Universal_Literal_String);
- H := Real_Convert
- (VAXFF_Last'Universal_Literal_String);
-
- elsif Digs = VAXDF_Digits then
- L := Real_Convert
- (VAXDF_First'Universal_Literal_String);
- H := Real_Convert
- (VAXDF_Last'Universal_Literal_String);
-
- else
- pragma Assert (Digs = VAXGF_Digits);
+ -- will adjust these types appropriately in the Vax_Float case if a
+ -- pragma Float_Representation (VAX_Float) is used.
- L := Real_Convert
- (VAXGF_First'Universal_Literal_String);
- H := Real_Convert
- (VAXGF_Last'Universal_Literal_String);
- end if;
-
- elsif Is_AAMP_Float (Id) then
- if Digs = AAMPS_Digits then
- L := Real_Convert
- (AAMPS_First'Universal_Literal_String);
- H := Real_Convert
- (AAMPS_Last'Universal_Literal_String);
-
- else
- pragma Assert (Digs = AAMPL_Digits);
- L := Real_Convert
- (AAMPL_First'Universal_Literal_String);
- H := Real_Convert
- (AAMPL_Last'Universal_Literal_String);
- end if;
-
- elsif Digs = IEEES_Digits then
- L := Real_Convert
- (IEEES_First'Universal_Literal_String);
- H := Real_Convert
- (IEEES_Last'Universal_Literal_String);
-
- elsif Digs = IEEEL_Digits then
- L := Real_Convert
- (IEEEL_First'Universal_Literal_String);
- H := Real_Convert
- (IEEEL_Last'Universal_Literal_String);
-
- else
- pragma Assert (Digs = IEEEX_Digits);
-
- L := Real_Convert
- (IEEEX_First'Universal_Literal_String);
- H := Real_Convert
- (IEEEX_Last'Universal_Literal_String);
- end if;
+ H := Make_Float_Literal (Stloc, Radix, Significand, Exponent);
+ L := Make_Float_Literal (Stloc, Radix, -Significand, Exponent);
Set_Etype (L, Id);
Set_Is_Static_Expression (L);
===================================================================
@@ -328,7 +328,6 @@ GNAT_ADA_OBJS = \
ada/tree_io.o \
ada/treepr.o \
ada/treeprs.o \
- ada/ttypef.o \
ada/ttypes.o \
ada/types.o \
ada/uintp.o \
@@ -1549,7 +1548,7 @@ ada/cstand.o : ada/ada.ads ada/a-except.
ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \
ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads ada/types.ads \
+ ada/tree_io.ads ada/ttypes.ads ada/types.ads \
ada/uintp.ads ada/uintp.adb ada/uname.ads ada/unchconv.ads \
ada/unchdeal.ads ada/urealp.ads ada/urealp.adb ada/widechar.ads
@@ -1643,7 +1642,7 @@ ada/eval_fat.o : ada/ada.ads ada/a-excep
ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \
ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tree_io.ads ada/ttypef.ads ada/types.ads ada/uintp.ads \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads \
ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads \
ada/urealp.adb
@@ -2388,7 +2387,7 @@ ada/exp_vfpt.o : ada/ada.ads ada/a-excep
ada/s-htable.ads ada/s-imenne.ads ada/s-memory.ads ada/s-os_lib.ads \
ada/s-parame.ads ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads \
ada/s-unstyp.ads ada/s-wchcon.ads ada/table.ads ada/table.adb \
- ada/tbuild.ads ada/tree_io.ads ada/ttypef.ads ada/types.ads \
+ ada/tbuild.ads ada/tree_io.ads ada/types.ads \
ada/uintp.ads ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads \
ada/urealp.ads ada/urealp.adb
@@ -3351,7 +3350,7 @@ ada/sem_attr.o : ada/ada.ads ada/a-chara
ada/s-stalib.ads ada/s-stoele.ads ada/s-stoele.adb ada/s-string.ads \
ada/s-traent.ads ada/s-unstyp.ads ada/s-utf_32.ads ada/s-wchcon.ads \
ada/table.ads ada/table.adb ada/targparm.ads ada/tbuild.ads \
- ada/tbuild.adb ada/tree_io.ads ada/ttypef.ads ada/ttypes.ads \
+ ada/tbuild.adb ada/tree_io.ads ada/ttypes.ads \
ada/types.ads ada/types.adb ada/uintp.ads ada/uintp.adb ada/uname.ads \
ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads ada/urealp.adb \
ada/validsw.ads ada/widechar.ads
@@ -4120,7 +4119,7 @@ ada/sem_vfpt.o : ada/ada.ads ada/a-excep
ada/s-memory.ads ada/s-os_lib.ads ada/s-parame.ads ada/s-rident.ads \
ada/s-stalib.ads ada/s-string.ads ada/s-traent.ads ada/s-unstyp.ads \
ada/s-wchcon.ads ada/table.ads ada/table.adb ada/targparm.ads \
- ada/tree_io.ads ada/ttypef.ads ada/types.ads ada/uintp.ads \
+ ada/tree_io.ads ada/types.ads ada/uintp.ads \
ada/uintp.adb ada/unchconv.ads ada/unchdeal.ads ada/urealp.ads
ada/sem_warn.o : ada/ada.ads ada/a-except.ads ada/a-unccon.ads \
@@ -4434,8 +4433,6 @@ ada/treeprs.o : ada/ada.ads ada/a-except
ada/treeprs.ads ada/types.ads ada/uintp.ads ada/unchconv.ads \
ada/unchdeal.ads ada/urealp.ads
-ada/ttypef.o : ada/system.ads ada/ttypef.ads
-
ada/ttypes.o : ada/ada.ads ada/a-unccon.ads ada/get_targ.ads \
ada/system.ads ada/s-exctab.ads ada/s-stalib.ads ada/s-unstyp.ads \
ada/ttypes.ads ada/types.ads ada/unchconv.ads ada/unchdeal.ads