+2014-11-20 Robert Dewar <dewar@adacore.com>
+
+ * inline.adb, sem_util.adb: Minor reformatting.
+
+2014-11-20 Pierre-Marie Derodat <derodat@adacore.com>
+
+ * uintp.h (UI_Eq): Declare.
+ * urealp.h (Norm_Den): Declare.
+ (Norm_Num): Declare.
+ * exp_dbug.adb (Is_Handled_Scale_Factor): New.
+ (Get_Encoded_Name): Do not output ___XF GNAT encodings
+ for fixed-point types when these can be handled by GCC's DWARF
+ back-end.
+
+2014-11-20 Thomas Quinot <quinot@adacore.com>
+
+ * sem_ch13.db (Inherit_Aspects_At_Freeze_Point): Inherit parent
+ SSO even if set through a pragma Default_Scalar_Storage_Order.
+ * freeze.adb (Set_SSO_From_Default): For a type extension,
+ do not let the default SSO override the parent SSO.
+ * gnat_rm.texi: document the above
+
2014-11-20 Robert Dewar <dewar@adacore.com>
* a-stream.ads, a-reatim.ads, a-calend.ads, sinfo.ads, s-crtl.ads,
-- Determine whether the bounds of E match the size of the type. This is
-- used to determine whether encoding is required for a discrete type.
+ function Is_Handled_Scale_Factor (U : Ureal) return Boolean;
+ -- Determine whether the back-end can handle some scale factor. When it
+ -- cannot, we have to output a GNAT encoding for the correspondig type.
+
procedure Output_Homonym_Numbers_Suffix;
-- If homonym numbers are stored, then output them into Name_Buffer
return Make_Null_Statement (Loc);
end Debug_Renaming_Declaration;
+ -----------------------------
+ -- Is_Handled_Scale_Factor --
+ -----------------------------
+
+ function Is_Handled_Scale_Factor (U : Ureal) return Boolean is
+ begin
+ -- Keep in sync with gigi (see E_*_Fixed_Point_Type handling in
+ -- decl.c:gnat_to_gnu_entity).
+ if UI_Eq (Numerator (U), Uint_1) then
+ if Rbase (U) = 2
+ or else Rbase (U) = 10
+ then
+ return True;
+ end if;
+ end if;
+
+ return
+ (UI_Is_In_Int_Range (Norm_Num (U))
+ and then UI_Is_In_Int_Range (Norm_Den (U)));
+ end Is_Handled_Scale_Factor;
+
----------------------
-- Get_Encoded_Name --
----------------------
Has_Suffix := True;
- -- Fixed-point case
+ -- Fixed-point case: generate GNAT encodings when asked to or when we
+ -- know the back-end will not be able to handle the scale factor.
- if Is_Fixed_Point_Type (E) then
+ if Is_Fixed_Point_Type (E)
+ and then
+ (GNAT_Encodings /= DWARF_GNAT_Encodings_Minimal
+ or else not Is_Handled_Scale_Factor (Small_Value (E)))
+ then
Get_External_Name (E, True, "XF_");
Add_Real_To_Buffer (Delta_Value (E));
procedure Set_SSO_From_Default (T : Entity_Id) is
begin
- if (Is_Record_Type (T) or else Is_Array_Type (T))
- and then Is_Base_Type (T)
+ -- Set default SSO for an array or record base type, except in the case
+ -- of a type extension (which always inherits the SSO of its parent
+ -- type).
+
+ if Is_Base_Type (T)
+ and then (Is_Array_Type (T)
+ or else
+ (Is_Record_Type (T)
+ and then not (Is_Tagged_Type (T)
+ and then
+ Is_Derived_Type (T))))
then
if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T))
or else
@noindent
Normally if no explicit @code{Scalar_Storage_Order} is given for a record
-type or array type, then the scalar storage order defaults to the ordinary
-default for the target. But this default may be overridden using this pragma.
-The pragma may appear as a configuration pragma, or locally within a package
-spec or declarative part. In the latter case, it applies to all subsequent
+type or array type, then the scalar storage order defaults to the native
+order for the target. However, this default may be overridden using
+this pragma (except for derived tagged types, which always default to
+inheriting the scalar storage order of their parent). The pragma may
+appear as a configuration pragma, or locally within a package spec or
+declarative part. In the latter case, it applies to all subsequent
types declared within that package spec or declarative part.
If this pragma is used as a configuration pragma which appears within a
Body_To_Inline := Copy_Separate_Tree (N);
end if;
- -- Remove all aspects/pragmas that have no meaining in an inlined
- -- body.
+ -- Remove all aspects/pragmas that have no meaning in an inlined body
Remove_Aspects_And_Pragmas (Body_To_Inline);
Append_New_Elmt (N, To => Backend_Calls);
end Register_Backend_Call;
- --------------------------
- -- Remove_Dead_Instance --
- --------------------------
-
- procedure Remove_Dead_Instance (N : Node_Id) is
- J : Int;
-
- begin
- J := 0;
- while J <= Pending_Instantiations.Last loop
- if Pending_Instantiations.Table (J).Inst_Node = N then
- Pending_Instantiations.Table (J).Inst_Node := Empty;
- return;
- end if;
-
- J := J + 1;
- end loop;
- end Remove_Dead_Instance;
-
--------------------------------
-- Remove_Aspects_And_Pragmas --
--------------------------------
Remove_Items (Declarations (Body_Decl));
end Remove_Aspects_And_Pragmas;
+ --------------------------
+ -- Remove_Dead_Instance --
+ --------------------------
+
+ procedure Remove_Dead_Instance (N : Node_Id) is
+ J : Int;
+
+ begin
+ J := 0;
+ while J <= Pending_Instantiations.Last loop
+ if Pending_Instantiations.Table (J).Inst_Node = N then
+ Pending_Instantiations.Table (J).Inst_Node := Empty;
+ return;
+ end if;
+
+ J := J + 1;
+ end loop;
+ end Remove_Dead_Instance;
+
end Inline;
-- evaluation of this aspect should be delayed to the
-- freeze point (why???)
- if No (Expr) or else Is_True (Static_Boolean (Expr))
+ if No (Expr)
+ or else Is_True (Static_Boolean (Expr))
then
Set_Uses_Lock_Free (E);
end if;
end if;
end if;
- if not Check_Primitive_Function (Subp)
- then
+ if not Check_Primitive_Function (Subp) then
Illegal_Indexing
("Indexing aspect requires a function that applies to type&");
return;
("variable indexing must return a reference type");
return;
- elsif Is_Access_Constant (Etype (First_Discriminant (Ret_Type)))
+ elsif Is_Access_Constant
+ (Etype (First_Discriminant (Ret_Type)))
then
Illegal_Indexing
("variable indexing must return an access to variable");
Set_Has_Volatile_Components (Imp_Bas_Typ);
end if;
- -- Finalize_Storage_Only.
+ -- Finalize_Storage_Only
if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False)
and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only)
Set_Universal_Aliasing (Imp_Bas_Typ);
end if;
- -- Record type specific aspects
+ -- Bit_Order
if Is_Record_Type (Typ) then
-
- -- Bit_Order
-
if not Has_Rep_Item (Typ, Name_Bit_Order, False)
and then Has_Rep_Item (Typ, Name_Bit_Order)
then
Reverse_Bit_Order (Entity (Name
(Get_Rep_Item (Typ, Name_Bit_Order)))));
end if;
+ end if;
+
+ -- Scalar_Storage_Order (first subtypes only)
+
+ if (Is_Record_Type (Typ) or else Is_Array_Type (Typ))
+ and then
+ Is_First_Subtype (Typ)
+ then
- -- Scalar_Storage_Order
+ -- For a type extension, always inherit from parent; otherwise
+ -- inherit if no default applies. Note: we do not check for
+ -- an explicit rep item on the parent type when inheriting,
+ -- because the parent SSO may itself have been set by default.
if not Has_Rep_Item (Typ, Name_Scalar_Storage_Order, False)
- and then Has_Rep_Item (Typ, Name_Scalar_Storage_Order)
+ and then (Is_Tagged_Type (Bas_Typ)
+ or else
+ not (SSO_Set_Low_By_Default (Bas_Typ)
+ or else
+ SSO_Set_High_By_Default (Bas_Typ)))
then
Set_Reverse_Storage_Order (Bas_Typ,
- Reverse_Storage_Order (Entity (Name
- (Get_Rep_Item (Typ, Name_Scalar_Storage_Order)))));
+ Reverse_Storage_Order (First_Subtype (Etype (Bas_Typ))));
-- Clear default SSO indications, since the inherited aspect
-- which was set explicitly overrides the default.
-- no longer a source construct, but it must still be recognized.
elsif Comes_From_Source (Decl)
- or else (Nkind_In (Decl, N_Subprogram_Body,
- N_Subprogram_Declaration)
- and then Is_Expression_Function
- (Defining_Entity (Decl)))
+ or else
+ (Nkind_In (Decl, N_Subprogram_Body,
+ N_Subprogram_Declaration)
+ and then Is_Expression_Function (Defining_Entity (Decl)))
then
exit;
end if;
* *
* C Header File *
* *
- * Copyright (C) 1992-2011, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2014, 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- *
#define Vector_To_Uint uintp__vector_to_uint
extern Uint Vector_To_Uint (Int_Vector, Boolean);
+/* Compare integer values for equality. */
+#define UI_Eq uintp__ui_eq
+extern Boolean UI_Eq (Uint, Uint);
+
/* Compare integer values for less than. */
#define UI_Lt uintp__ui_lt
extern Boolean UI_Lt (Uint, Uint);
* *
* C Header File *
* *
- * Copyright (C) 1992-2011, Free Software Foundation, Inc. *
+ * Copyright (C) 1992-2014, 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- *
#define Rbase urealp__rbase
extern Nat Rbase (Ureal);
+#define Norm_Den urealp__norm_den
+extern Uint Norm_Den (Ureal);
+
+#define Norm_Num urealp__norm_num
+extern Uint Norm_Num (Ureal);
+
#define UR_Is_Negative urealp__ur_is_negative
extern Boolean UR_Is_Negative (Ureal);
projects / gcc.git / commitdiff