OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

[multiple changes] 

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

From-SVN: r217842
This commit is contained in:
Arnaud Charlet 2014-11-20 12:34:09 +01:00
parent 697b781a68
commit eefd2467a6
9 changed files with 132 additions and 48 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
gcc/ada/ChangeLog
View File

@ -1,3 +1,25 @@
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,

34
gcc/ada/exp_dbug.adb
View File

@ -133,6 +133,10 @@ package body Exp_Dbug is
-- 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
@ -535,6 +539,27 @@ package body Exp_Dbug is
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 --
----------------------
@ -593,9 +618,14 @@ package body Exp_Dbug is
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));

13
gcc/ada/freeze.adb
View File

@ -7695,8 +7695,17 @@ package body Freeze is
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

10
gcc/ada/gnat_rm.texi
View File

@ -2552,10 +2552,12 @@ pragma Default_Scalar_Storage_Order (High_Order_First | Low_Order_First);
@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

41
gcc/ada/inline.adb
View File

@ -1655,8 +1655,7 @@ package body Inline is
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);
@ -3938,25 +3937,6 @@ package body Inline is
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 --
--------------------------------
@ -4016,4 +3996,23 @@ package body Inline is
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;

38
gcc/ada/sem_ch13.adb
View File

@ -3035,7 +3035,8 @@ package body Sem_Ch13 is
-- 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;
@ -3725,8 +3726,7 @@ package body Sem_Ch13 is
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;
@ -3798,7 +3798,8 @@ package body Sem_Ch13 is
("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");
@ -10882,7 +10883,7 @@ package body Sem_Ch13 is
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)
@ -10900,12 +10901,9 @@ package body Sem_Ch13 is
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
@ -10913,15 +10911,29 @@ package body Sem_Ch13 is
Reverse_Bit_Order (Entity (Name
(Get_Rep_Item (Typ, Name_Bit_Order)))));
end if;
end if;
-- Scalar_Storage_Order
-- Scalar_Storage_Order (first subtypes only)
if (Is_Record_Type (Typ) or else Is_Array_Type (Typ))
and then
Is_First_Subtype (Typ)
then
-- 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.

8
gcc/ada/sem_util.adb
View File

@ -5966,10 +5966,10 @@ package body Sem_Util is
-- 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;

6
gcc/ada/uintp.h
View File

@ -6,7 +6,7 @@
* *
* 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- *
@ -79,6 +79,10 @@ typedef struct {const int *Array; Vector_Template *Bounds; }
#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);

8
gcc/ada/urealp.h
View File

@ -6,7 +6,7 @@
* *
* 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- *
@ -41,6 +41,12 @@ extern Uint Denominator (Ureal);
#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);