+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.
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);
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);
with Output; use Output;
with Sinfo; use Sinfo;
with Stand; use Stand;
-with Targparm; use Targparm;
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
-- 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
-- (unused) Flag253
-- (unused) Flag254
- -----------------
- -- Local types --
- -----------------
-
- type Float_Rep_Kind is (IEEE_Binary, VAX_Native, AAMP);
-
-----------------------
-- Local subprograms --
-----------------------
-- 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;
----------------
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
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);
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);
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));
Concurrent_Kind =>
Write_Str ("Direct_Primitive_Operations");
+ when Float_Kind =>
+ Write_Str ("Float_Rep");
+
when E_In_Parameter |
E_Constant =>
Write_Str ("Discriminal_Link");
-- 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
-- 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
-- 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)
-- Scalar_Range (Node20)
-- Type_Low_Bound (synth)
-- Type_High_Bound (synth)
+ -- Vax_Float (synth)
-- (plus type attributes)
-- E_Function
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 --
---------------
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;
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;
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);
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);
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);
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);
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
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
-- 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));
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);
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 --
-----------------------------
-- 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
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);
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);
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);
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);
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);
OSDN Git Service
