[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:
parent
697b781a68
commit
eefd2467a6
|
@ -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>
|
2014-11-20 Robert Dewar <dewar@adacore.com>
|
||||||
|
|
||||||
* a-stream.ads, a-reatim.ads, a-calend.ads, sinfo.ads, s-crtl.ads,
|
* a-stream.ads, a-reatim.ads, a-calend.ads, sinfo.ads, s-crtl.ads,
|
||||||
|
|
|
@ -133,6 +133,10 @@ package body Exp_Dbug is
|
||||||
-- Determine whether the bounds of E match the size of the type. This 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.
|
-- 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;
|
procedure Output_Homonym_Numbers_Suffix;
|
||||||
-- If homonym numbers are stored, then output them into Name_Buffer
|
-- 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);
|
return Make_Null_Statement (Loc);
|
||||||
end Debug_Renaming_Declaration;
|
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 --
|
-- Get_Encoded_Name --
|
||||||
----------------------
|
----------------------
|
||||||
|
@ -593,9 +618,14 @@ package body Exp_Dbug is
|
||||||
|
|
||||||
Has_Suffix := True;
|
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_");
|
Get_External_Name (E, True, "XF_");
|
||||||
Add_Real_To_Buffer (Delta_Value (E));
|
Add_Real_To_Buffer (Delta_Value (E));
|
||||||
|
|
||||||
|
|
|
@ -7695,8 +7695,17 @@ package body Freeze is
|
||||||
|
|
||||||
procedure Set_SSO_From_Default (T : Entity_Id) is
|
procedure Set_SSO_From_Default (T : Entity_Id) is
|
||||||
begin
|
begin
|
||||||
if (Is_Record_Type (T) or else Is_Array_Type (T))
|
-- Set default SSO for an array or record base type, except in the case
|
||||||
and then Is_Base_Type (T)
|
-- 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
|
then
|
||||||
if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T))
|
if ((Bytes_Big_Endian and then SSO_Set_Low_By_Default (T))
|
||||||
or else
|
or else
|
||||||
|
|
|
@ -2552,10 +2552,12 @@ pragma Default_Scalar_Storage_Order (High_Order_First | Low_Order_First);
|
||||||
|
|
||||||
@noindent
|
@noindent
|
||||||
Normally if no explicit @code{Scalar_Storage_Order} is given for a record
|
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
|
type or array type, then the scalar storage order defaults to the native
|
||||||
default for the target. But this default may be overridden using this pragma.
|
order for the target. However, this default may be overridden using
|
||||||
The pragma may appear as a configuration pragma, or locally within a package
|
this pragma (except for derived tagged types, which always default to
|
||||||
spec or declarative part. In the latter case, it applies to all subsequent
|
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.
|
types declared within that package spec or declarative part.
|
||||||
|
|
||||||
If this pragma is used as a configuration pragma which appears within a
|
If this pragma is used as a configuration pragma which appears within a
|
||||||
|
|
|
@ -1655,8 +1655,7 @@ package body Inline is
|
||||||
Body_To_Inline := Copy_Separate_Tree (N);
|
Body_To_Inline := Copy_Separate_Tree (N);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Remove all aspects/pragmas that have no meaining in an inlined
|
-- Remove all aspects/pragmas that have no meaning in an inlined body
|
||||||
-- body.
|
|
||||||
|
|
||||||
Remove_Aspects_And_Pragmas (Body_To_Inline);
|
Remove_Aspects_And_Pragmas (Body_To_Inline);
|
||||||
|
|
||||||
|
@ -3938,25 +3937,6 @@ package body Inline is
|
||||||
Append_New_Elmt (N, To => Backend_Calls);
|
Append_New_Elmt (N, To => Backend_Calls);
|
||||||
end Register_Backend_Call;
|
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_Aspects_And_Pragmas --
|
||||||
--------------------------------
|
--------------------------------
|
||||||
|
@ -4016,4 +3996,23 @@ package body Inline is
|
||||||
Remove_Items (Declarations (Body_Decl));
|
Remove_Items (Declarations (Body_Decl));
|
||||||
end Remove_Aspects_And_Pragmas;
|
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;
|
end Inline;
|
||||||
|
|
|
@ -3035,7 +3035,8 @@ package body Sem_Ch13 is
|
||||||
-- evaluation of this aspect should be delayed to the
|
-- evaluation of this aspect should be delayed to the
|
||||||
-- freeze point (why???)
|
-- freeze point (why???)
|
||||||
|
|
||||||
if No (Expr) or else Is_True (Static_Boolean (Expr))
|
if No (Expr)
|
||||||
|
or else Is_True (Static_Boolean (Expr))
|
||||||
then
|
then
|
||||||
Set_Uses_Lock_Free (E);
|
Set_Uses_Lock_Free (E);
|
||||||
end if;
|
end if;
|
||||||
|
@ -3725,8 +3726,7 @@ package body Sem_Ch13 is
|
||||||
end if;
|
end if;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
if not Check_Primitive_Function (Subp)
|
if not Check_Primitive_Function (Subp) then
|
||||||
then
|
|
||||||
Illegal_Indexing
|
Illegal_Indexing
|
||||||
("Indexing aspect requires a function that applies to type&");
|
("Indexing aspect requires a function that applies to type&");
|
||||||
return;
|
return;
|
||||||
|
@ -3798,7 +3798,8 @@ package body Sem_Ch13 is
|
||||||
("variable indexing must return a reference type");
|
("variable indexing must return a reference type");
|
||||||
return;
|
return;
|
||||||
|
|
||||||
elsif Is_Access_Constant (Etype (First_Discriminant (Ret_Type)))
|
elsif Is_Access_Constant
|
||||||
|
(Etype (First_Discriminant (Ret_Type)))
|
||||||
then
|
then
|
||||||
Illegal_Indexing
|
Illegal_Indexing
|
||||||
("variable indexing must return an access to variable");
|
("variable indexing must return an access to variable");
|
||||||
|
@ -10882,7 +10883,7 @@ package body Sem_Ch13 is
|
||||||
Set_Has_Volatile_Components (Imp_Bas_Typ);
|
Set_Has_Volatile_Components (Imp_Bas_Typ);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Finalize_Storage_Only.
|
-- Finalize_Storage_Only
|
||||||
|
|
||||||
if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False)
|
if not Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only, False)
|
||||||
and then Has_Rep_Pragma (Typ, Name_Finalize_Storage_Only)
|
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);
|
Set_Universal_Aliasing (Imp_Bas_Typ);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- Record type specific aspects
|
-- Bit_Order
|
||||||
|
|
||||||
if Is_Record_Type (Typ) then
|
if Is_Record_Type (Typ) then
|
||||||
|
|
||||||
-- Bit_Order
|
|
||||||
|
|
||||||
if not Has_Rep_Item (Typ, Name_Bit_Order, False)
|
if not Has_Rep_Item (Typ, Name_Bit_Order, False)
|
||||||
and then Has_Rep_Item (Typ, Name_Bit_Order)
|
and then Has_Rep_Item (Typ, Name_Bit_Order)
|
||||||
then
|
then
|
||||||
|
@ -10913,15 +10911,29 @@ package body Sem_Ch13 is
|
||||||
Reverse_Bit_Order (Entity (Name
|
Reverse_Bit_Order (Entity (Name
|
||||||
(Get_Rep_Item (Typ, Name_Bit_Order)))));
|
(Get_Rep_Item (Typ, Name_Bit_Order)))));
|
||||||
end if;
|
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)
|
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
|
then
|
||||||
Set_Reverse_Storage_Order (Bas_Typ,
|
Set_Reverse_Storage_Order (Bas_Typ,
|
||||||
Reverse_Storage_Order (Entity (Name
|
Reverse_Storage_Order (First_Subtype (Etype (Bas_Typ))));
|
||||||
(Get_Rep_Item (Typ, Name_Scalar_Storage_Order)))));
|
|
||||||
|
|
||||||
-- Clear default SSO indications, since the inherited aspect
|
-- Clear default SSO indications, since the inherited aspect
|
||||||
-- which was set explicitly overrides the default.
|
-- which was set explicitly overrides the default.
|
||||||
|
|
|
@ -5966,10 +5966,10 @@ package body Sem_Util is
|
||||||
-- no longer a source construct, but it must still be recognized.
|
-- no longer a source construct, but it must still be recognized.
|
||||||
|
|
||||||
elsif Comes_From_Source (Decl)
|
elsif Comes_From_Source (Decl)
|
||||||
or else (Nkind_In (Decl, N_Subprogram_Body,
|
or else
|
||||||
N_Subprogram_Declaration)
|
(Nkind_In (Decl, N_Subprogram_Body,
|
||||||
and then Is_Expression_Function
|
N_Subprogram_Declaration)
|
||||||
(Defining_Entity (Decl)))
|
and then Is_Expression_Function (Defining_Entity (Decl)))
|
||||||
then
|
then
|
||||||
exit;
|
exit;
|
||||||
end if;
|
end if;
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
* *
|
* *
|
||||||
* C Header File *
|
* 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 *
|
* 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- *
|
* 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
|
#define Vector_To_Uint uintp__vector_to_uint
|
||||||
extern Uint Vector_To_Uint (Int_Vector, Boolean);
|
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. */
|
/* Compare integer values for less than. */
|
||||||
#define UI_Lt uintp__ui_lt
|
#define UI_Lt uintp__ui_lt
|
||||||
extern Boolean UI_Lt (Uint, Uint);
|
extern Boolean UI_Lt (Uint, Uint);
|
||||||
|
|
|
@ -6,7 +6,7 @@
|
||||||
* *
|
* *
|
||||||
* C Header File *
|
* 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 *
|
* 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- *
|
* 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
|
#define Rbase urealp__rbase
|
||||||
extern Nat Rbase (Ureal);
|
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
|
#define UR_Is_Negative urealp__ur_is_negative
|
||||||
extern Boolean UR_Is_Negative (Ureal);
|
extern Boolean UR_Is_Negative (Ureal);
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue