cstand.adb (Build_Float_Type): Set Float_Rep according to platform.

2010-10-22  Geert Bosch  <bosch@adacore.com>

	* cstand.adb (Build_Float_Type): Set Float_Rep according to platform.
	* einfo.ads (Float_Rep): New attribute.
	(Float_Rep_Kind): Move from body. Add comments.
	* einfo.adb (Float_Rep_Kind): Move to spec
	(Float_Rep): Now a real field instead of local function.
	(Set_Float_Rep): New procedure to set floating point representation
	(Set_Vax_Float): Remove.
	(Write_Entity_Flags): Remove Vax_Float flag.
	(Write_Field10_Name): Add E_Floating_Point_Type case for Float_Rep.
	* exp_attr.adb (Attribute_Valid): Use case statement for representation
	specific processing.
	* sem_ch3.adb (Build_Derived_Numeric_Type,
	Floating_Point_Type_Declaration): Set Float_Rep instead of Vax_Float
	attribute.
	* sem_util.ads, sem_util.adb (Is_AAMP_Float): Remove.
	* sem_vfpt.adb (Set_D_Float, Set_F_Float, Set_G_Float, Set_IEEE_Long,
	Set_IEEE_Short): Set Float_Rep instead of Vax_Float attribute.

From-SVN: r165816

gcc/ada/ChangeLog

+2010-10-22  Geert Bosch  <bosch@adacore.com>
+
+	* cstand.adb (Build_Float_Type): Set Float_Rep according to platform.
+	* einfo.ads (Float_Rep): New attribute.
+	(Float_Rep_Kind): Move from body. Add comments.
+	* einfo.adb (Float_Rep_Kind): Move to spec
+	(Float_Rep): Now a real field instead of local function.
+	(Set_Float_Rep): New procedure to set floating point representation
+	(Set_Vax_Float): Remove.
+	(Write_Entity_Flags): Remove Vax_Float flag.
+	(Write_Field10_Name): Add E_Floating_Point_Type case for Float_Rep.
+	* exp_attr.adb (Attribute_Valid): Use case statement for representation
+	specific processing.
+	* sem_ch3.adb (Build_Derived_Numeric_Type,
+	Floating_Point_Type_Declaration): Set Float_Rep instead of Vax_Float
+	attribute.
+	* sem_util.ads, sem_util.adb (Is_AAMP_Float): Remove.
+	* sem_vfpt.adb (Set_D_Float, Set_F_Float, Set_G_Float, Set_IEEE_Long,
+	Set_IEEE_Short): Set Float_Rep instead of Vax_Float attribute.
+
 2010-10-22  Robert Dewar  <dewar@adacore.com>
 
 	* sprint.adb: Minor reformatting.

gcc/ada/cstand.adb

@@ -140,8 +140,17 @@ package body CStand is
       Set_Type_Definition (Parent (E),
         Make_Floating_Point_Definition (Stloc,
           Digits_Expression => Make_Integer (UI_From_Int (Digs))));
+
       Set_Ekind                      (E, E_Floating_Point_Type);
       Set_Etype                      (E, E);
+
+      if AAMP_On_Target then
+         Set_Float_Rep (E, AAMP);
+
+      else
+         Set_Float_Rep (E, IEEE_Binary);
+      end if;
+
       Init_Size                      (E, Siz);
       Set_Elem_Alignment             (E);
       Init_Digits_Value              (E, Digs);
@@ -1874,9 +1883,9 @@ package body CStand is
 
    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.
+      --  Standard, Float_Rep will never be VAX_Native. Circuitry in Sem_Vfpt
+      --  will adjust these types appropriately VAX_Native if a pragma
+      --  Float_Representation (VAX_Float) is used.
 
       H := Make_Float_Literal (Stloc, Radix, Significand, Exponent);
       L := Make_Float_Literal (Stloc, Radix, -Significand, Exponent);

gcc/ada/einfo.adb

@@ -37,7 +37,6 @@ with Nlists;   use Nlists;
 with Output;   use Output;
 with Sinfo;    use Sinfo;
 with Stand;    use Stand;
-with Targparm; use Targparm;
 
 package body Einfo is
 
@@ -88,6 +87,7 @@ package body Einfo is
 
    --    Direct_Primitive_Operations     Elist10
    --    Discriminal_Link                Node10
+   --    Float_Rep                       Uint10 (but returns Float_Rep_Kind)
    --    Handler_Records                 List10
    --    Normalized_Position_Max         Uint10
 
@@ -406,7 +406,7 @@ package body Einfo is
    --    Is_Compilation_Unit             Flag149
    --    Has_Pragma_Elaborate_Body       Flag150
 
-   --    Vax_Float                       Flag151
+   --    (unused)                        Flag151
    --    Entry_Accepted                  Flag152
    --    Is_Obsolescent                  Flag153
    --    Has_Per_Object_Constraint       Flag154
@@ -521,12 +521,6 @@ package body Einfo is
    --    (unused)                        Flag253
    --    (unused)                        Flag254
 
-   -----------------
-   -- Local types --
-   -----------------
-
-   type Float_Rep_Kind is (IEEE_Binary, VAX_Native, AAMP);
-
    -----------------------
    -- Local subprograms --
    -----------------------
@@ -535,23 +529,14 @@ 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
+   function Float_Rep (Id : E) return F 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;
+      return F'Val (UI_To_Int (Uint10 (Base_Type (Id))));
    end Float_Rep;
 
    ----------------
@@ -2873,7 +2858,7 @@ package body Einfo is
 
    function Vax_Float (Id : E) return B is
    begin
-      return Flag151 (Base_Type (Id));
+      return Is_Floating_Point_Type (Id) and then Float_Rep (Id) = VAX_Native;
    end Vax_Float;
 
    function Warnings_Off (Id : E) return B is
@@ -3685,6 +3670,12 @@ package body Einfo is
       Set_Node6 (Id, V);
    end Set_First_Rep_Item;
 
+   procedure Set_Float_Rep (Id : E; V : F) is
+      pragma Assert (Ekind (Id) = E_Floating_Point_Type);
+   begin
+      Set_Uint10 (Id, UI_From_Int (F'Pos (V)));
+   end Set_Float_Rep;
+
    procedure Set_Freeze_Node (Id : E; V : N) is
    begin
       Set_Node7 (Id, V);
@@ -5375,12 +5366,6 @@ package body Einfo is
       Set_Flag222 (Id, V);
    end Set_Used_As_Generic_Actual;
 
-   procedure Set_Vax_Float (Id : E; V : B := True) is
-   begin
-      pragma Assert (Id = Base_Type (Id));
-      Set_Flag151 (Id, V);
-   end Set_Vax_Float;
-
    procedure Set_Warnings_Off (Id : E; V : B := True) is
    begin
       Set_Flag96 (Id, V);
@@ -7499,7 +7484,6 @@ package body Einfo is
       W ("Universal_Aliasing",              Flag216 (Id));
       W ("Used_As_Generic_Actual",          Flag222 (Id));
       W ("Uses_Sec_Stack",                  Flag95  (Id));
-      W ("Vax_Float",                       Flag151 (Id));
       W ("Warnings_Off",                    Flag96  (Id));
       W ("Warnings_Off_Used",               Flag236 (Id));
       W ("Warnings_Off_Used_Unmodified",    Flag237 (Id));
@@ -7735,6 +7719,9 @@ package body Einfo is
               Concurrent_Kind                              =>
             Write_Str ("Direct_Primitive_Operations");
 
+         when Float_Kind                                 =>
+            Write_Str ("Float_Rep");
+
          when E_In_Parameter                               |
               E_Constant                                   =>
             Write_Str ("Discriminal_Link");

gcc/ada/einfo.ads

@@ -1264,6 +1264,11 @@ package Einfo is
 --       Note in particular that size clauses are present only for this
 --       purpose, and should only be accessed if Has_Size_Clause is set.
 
+--    Float_Rep (Uint8)
+--       Present in floating-point entities. Contains a value of type
+--       Float_Rep_Kind. Together with the Digits_Value uniquely defines
+--       the floating-point representation to be used.
+
 --    Freeze_Node (Node7)
 --       Present in all entities. If there is an associated freeze node for
 --       the entity, this field references this freeze node. If no freeze
@@ -3786,11 +3791,6 @@ package Einfo is
 --       entries). Set to True when secondary stack is used in this scope and
 --       must be released on exit unless Sec_Stack_Needed_For_Return is set.
 
---    Vax_Float (Flag151) [base type only]
---       Present in all type and subtype entities. Set only on the base type of
---       float types with Vax format. The particular format is determined by
---       the Digits_Value value which is 6,9,15 for F_Float, D_Float, G_Float.
-
 --    Warnings_Off (Flag96)
 --       Present in all entities. Set if a pragma Warnings (Off, entity-name)
 --       is used to suppress warnings for a given entity. It is also used by
@@ -5094,6 +5094,7 @@ package Einfo is
    --  E_Floating_Point_Type
    --  E_Floating_Point_Subtype
    --    Digits_Value                        (Uint17)
+   --    Float_Rep                           (Uint8)    (Float_Rep_Kind)
    --    Machine_Emax_Value                  (synth)
    --    Machine_Emin_Value                  (synth)
    --    Machine_Mantissa_Value              (synth)
@@ -5108,6 +5109,7 @@ package Einfo is
    --    Scalar_Range                        (Node20)
    --    Type_Low_Bound                      (synth)
    --    Type_High_Bound                     (synth)
+   --    Vax_Float                           (synth)
    --    (plus type attributes)
 
    --  E_Function
@@ -5669,6 +5671,15 @@ package Einfo is
       Calign_Component_Size_4, -- natural for size <= 4, 4 for size >= 4
       Calign_Storage_Unit);    -- all components byte aligned
 
+   ----------------------------------
+   -- Floating Point Repesentation --
+   ----------------------------------
+
+   type Float_Rep_Kind is (
+      IEEE_Binary,  -- IEEE 754p conform binary format
+      VAX_Native,   -- VAX D, F, G or H format
+      AAMP);        -- AAMP format
+
    ---------------
    -- Iterators --
    ---------------
@@ -5848,6 +5859,7 @@ package Einfo is
    subtype B is Boolean;
    subtype C is Component_Alignment_Kind;
    subtype E is Entity_Id;
+   subtype F is Float_Rep_Kind;
    subtype M is Mechanism_Type;
    subtype N is Node_Id;
    subtype U is Uint;
@@ -5953,6 +5965,7 @@ package Einfo is
    function First_Optional_Parameter            (Id : E) return E;
    function First_Private_Entity                (Id : E) return E;
    function First_Rep_Item                      (Id : E) return N;
+   function Float_Rep                           (Id : E) return F;
    function Freeze_Node                         (Id : E) return N;
    function From_With_Type                      (Id : E) return B;
    function Full_View                           (Id : E) return E;
@@ -6532,6 +6545,7 @@ package Einfo is
    procedure Set_First_Optional_Parameter        (Id : E; V : E);
    procedure Set_First_Private_Entity            (Id : E; V : E);
    procedure Set_First_Rep_Item                  (Id : E; V : N);
+   procedure Set_Float_Rep                       (Id : E; V : F);
    procedure Set_Freeze_Node                     (Id : E; V : N);
    procedure Set_From_With_Type                  (Id : E; V : B := True);
    procedure Set_Full_View                       (Id : E; V : E);
@@ -6825,7 +6839,6 @@ package Einfo is
    procedure Set_Unset_Reference                 (Id : E; V : N);
    procedure Set_Used_As_Generic_Actual          (Id : E; V : B := True);
    procedure Set_Uses_Sec_Stack                  (Id : E; V : B := True);
-   procedure Set_Vax_Float                       (Id : E; V : B := True);
    procedure Set_Warnings_Off                    (Id : E; V : B := True);
    procedure Set_Warnings_Off_Used               (Id : E; V : B := True);
    procedure Set_Warnings_Off_Used_Unmodified    (Id : E; V : B := True);
@@ -7558,7 +7571,6 @@ package Einfo is
    pragma Inline (Unset_Reference);
    pragma Inline (Used_As_Generic_Actual);
    pragma Inline (Uses_Sec_Stack);
-   pragma Inline (Vax_Float);
    pragma Inline (Warnings_Off);
    pragma Inline (Warnings_Off_Used);
    pragma Inline (Warnings_Off_Used_Unmodified);
@@ -7952,7 +7964,6 @@ package Einfo is
    pragma Inline (Set_Unset_Reference);
    pragma Inline (Set_Used_As_Generic_Actual);
    pragma Inline (Set_Uses_Sec_Stack);
-   pragma Inline (Set_Vax_Float);
    pragma Inline (Set_Warnings_Off);
    pragma Inline (Set_Warnings_Off_Used);
    pragma Inline (Set_Warnings_Off_Used_Unmodified);

gcc/ada/exp_attr.adb

@@ -4771,53 +4771,54 @@ package body Exp_Attr is
                Ftp : Entity_Id;
 
             begin
-               --  For vax fpt types, call appropriate routine in special vax
-               --  floating point unit. We do not have to worry about loads in
-               --  this case, since these types have no signalling NaN's.
 
-               if Vax_Float (Btyp) then
-                  Expand_Vax_Valid (N);
+               case Float_Rep (Btyp) is
+                  --  For vax fpt types, call appropriate routine in special
+                  --  vax floating point unit. We do not have to worry about
+                  --  loads in this case, since these types have no signalling
+                  --  NaN's.
 
-               --  The AAMP back end handles Valid for floating-point types
+                  when VAX_Native => Expand_Vax_Valid (N);
 
-               elsif Is_AAMP_Float (Btyp) then
-                  Analyze_And_Resolve (Pref, Ptyp);
-                  Set_Etype (N, Standard_Boolean);
-                  Set_Analyzed (N);
+                  --  The AAMP back end handles Valid for floating-point types
 
-               --  Non VAX float case
+                  when AAMP =>
+                     Analyze_And_Resolve (Pref, Ptyp);
+                     Set_Etype (N, Standard_Boolean);
+                     Set_Analyzed (N);
 
-               else
-                  Find_Fat_Info (Ptyp, Ftp, Pkg);
-
-                  --  If the floating-point object might be unaligned, we need
-                  --  to call the special routine Unaligned_Valid, which makes
-                  --  the needed copy, being careful not to load the value into
-                  --  any floating-point register. The argument in this case is
-                  --  obj'Address (see Unaligned_Valid routine in Fat_Gen).
-
-                  if Is_Possibly_Unaligned_Object (Pref) then
-                     Expand_Fpt_Attribute
-                       (N, Pkg, Name_Unaligned_Valid,
-                        New_List (
-                          Make_Attribute_Reference (Loc,
-                            Prefix => Relocate_Node (Pref),
-                            Attribute_Name => Name_Address)));
+                  when IEEE_Binary =>
+                     Find_Fat_Info (Ptyp, Ftp, Pkg);
 
-                  --  In the normal case where we are sure the object is
-                  --  aligned, we generate a call to Valid, and the argument in
-                  --  this case is obj'Unrestricted_Access (after converting
-                  --  obj to the right floating-point type).
+                     --  If the floating-point object might be unaligned, we
+                     --  need to call the special routine Unaligned_Valid,
+                     --  which makes the needed copy, being careful not to
+                     --  load the value into any floating-point register.
+                     --  The argument in this case is obj'Address (see
+                     --  Unaligned_Valid routine in Fat_Gen).
 
-                  else
-                     Expand_Fpt_Attribute
-                       (N, Pkg, Name_Valid,
-                        New_List (
-                          Make_Attribute_Reference (Loc,
-                            Prefix => Unchecked_Convert_To (Ftp, Pref),
-                            Attribute_Name => Name_Unrestricted_Access)));
-                  end if;
-               end if;
+                     if Is_Possibly_Unaligned_Object (Pref) then
+                        Expand_Fpt_Attribute
+                          (N, Pkg, Name_Unaligned_Valid,
+                           New_List (
+                             Make_Attribute_Reference (Loc,
+                               Prefix => Relocate_Node (Pref),
+                               Attribute_Name => Name_Address)));
+
+                     --  In the normal case where we are sure the object is
+                     --  aligned, we generate a call to Valid, and the argument
+                     --  in this case is obj'Unrestricted_Access (after
+                     --  converting obj to the right floating-point type).
+
+                     else
+                        Expand_Fpt_Attribute
+                          (N, Pkg, Name_Valid,
+                           New_List (
+                             Make_Attribute_Reference (Loc,
+                               Prefix => Unchecked_Convert_To (Ftp, Pref),
+                               Attribute_Name => Name_Unrestricted_Access)));
+                     end if;
+               end case;
 
                --  One more task, we still need a range check. Required
                --  only if we have a constraint, since the Valid routine
@@ -5468,7 +5469,7 @@ package body Exp_Attr is
                raise Program_Error;
          end case;
 
-      --  If neither the base type nor the root type is VAX_Float then VAX
+      --  If neither the base type nor the root type is VAX_Native then VAX
       --  float is out of the picture, and we can just use the root type.
 
       else

gcc/ada/sem_ch3.adb

@@ -5646,7 +5646,7 @@ package body Sem_Ch3 is
          --  already have been set if there was a constraint present.
 
          Set_Digits_Value (Implicit_Base, Digits_Value (Parent_Base));
-         Set_Vax_Float    (Implicit_Base, Vax_Float    (Parent_Base));
+         Set_Float_Rep    (Implicit_Base, Float_Rep    (Parent_Base));
 
          if No_Constraint then
             Set_Digits_Value (Derived_Type, Digits_Value (Parent_Type));
@@ -14730,7 +14730,7 @@ package body Sem_Ch3 is
       Set_RM_Size        (Implicit_Base, RM_Size        (Base_Typ));
       Set_First_Rep_Item (Implicit_Base, First_Rep_Item (Base_Typ));
       Set_Digits_Value   (Implicit_Base, Digits_Value   (Base_Typ));
-      Set_Vax_Float      (Implicit_Base, Vax_Float      (Base_Typ));
+      Set_Float_Rep      (Implicit_Base, Float_Rep      (Base_Typ));
 
       Set_Ekind          (T, E_Floating_Point_Subtype);
       Set_Etype          (T, Implicit_Base);

gcc/ada/sem_util.adb

@@ -5703,18 +5703,6 @@ package body Sem_Util is
       end loop;
    end Inspect_Deferred_Constant_Completion;
 
-   -------------------
-   -- Is_AAMP_Float --
-   -------------------
-
-   function Is_AAMP_Float (E : Entity_Id) return Boolean is
-      pragma Assert (Is_Type (E));
-   begin
-      return AAMP_On_Target
-         and then Is_Floating_Point_Type (E)
-         and then E = Base_Type (E);
-   end Is_AAMP_Float;
-
    -----------------------------
    -- Is_Actual_Out_Parameter --
    -----------------------------

gcc/ada/sem_util.ads

@@ -653,14 +653,6 @@ package Sem_Util is
    --  whether they have been completed by a full constant declaration or an
    --  Import pragma. Emit the error message if that is not the case.
 
-   function Is_AAMP_Float (E : Entity_Id) return Boolean;
-   --  Defined for all type entities. Returns True only for the base type of
-   --  float types with AAMP format. The particular format is determined by the
-   --  Digits_Value value which is 6 for the 32-bit floating point type, or 9
-   --  for the 48-bit type. This is not an attribute function (like VAX_Float)
-   --  in order to not use up an extra flag and to prevent the dependency of
-   --  Einfo on Targparm which would be required for a synthesized attribute.
-
    function Is_Actual_Out_Parameter (N : Node_Id) return Boolean;
    --  Determines if N is an actual parameter of out mode in a subprogram call
 

gcc/ada/sem_vfpt.adb

@@ -37,12 +37,11 @@ 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));
       Init_Digits_Value (Base_Type (E), VAXDF_Digits);
-      Set_Vax_Float     (Base_Type (E), True);
+      Set_Float_Rep     (Base_Type (E), VAX_Native);
       Set_Float_Bounds  (Base_Type (E));
 
       Init_Size         (E, 64);
@@ -57,12 +56,11 @@ 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));
       Init_Digits_Value (Base_Type (E), VAXFF_Digits);
-      Set_Vax_Float     (Base_Type (E), True);
+      Set_Float_Rep     (Base_Type (E), VAX_Native);
       Set_Float_Bounds  (Base_Type (E));
 
       Init_Size         (E, 32);
@@ -77,12 +75,11 @@ 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));
       Init_Digits_Value (Base_Type (E), VAXGF_Digits);
-      Set_Vax_Float     (Base_Type (E), True);
+      Set_Float_Rep     (Base_Type (E), VAX_Native);
       Set_Float_Bounds  (Base_Type (E));
 
       Init_Size         (E, 64);
@@ -97,12 +94,11 @@ 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));
       Init_Digits_Value (Base_Type (E), IEEEL_Digits);
-      Set_Vax_Float     (Base_Type (E), False);
+      Set_Float_Rep     (Base_Type (E), IEEE_Binary);
       Set_Float_Bounds  (Base_Type (E));
 
       Init_Size         (E, 64);
@@ -117,12 +113,11 @@ 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));
       Init_Digits_Value (Base_Type (E), IEEES_Digits);
-      Set_Vax_Float     (Base_Type (E), False);
+      Set_Float_Rep     (Base_Type (E), IEEE_Binary);
       Set_Float_Bounds  (Base_Type (E));
 
       Init_Size         (E, 32);