From 3e3bc136d4c43f8741ece96b7ab992ef08b574f0 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 14:33:25 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Claire Dross * sem_prag.adb (Collect_Inherited_Class_Wide_Conditions): Go to ultimate alias when accessing overridden operation. Indeed, if the overridden operation is itself inherited, it won't have any explicit contract. 2017-04-25 Ed Schonberg * sem_warn.adb (Warn_On_Overlapping_Actuals): There can be no overlap if the two formals have different types, because formally the corresponding actuals cannot designate the same objects. 2017-04-25 Ed Schonberg * sem_dim.adb (Dimensions_Of_Operand): minot cleanups: a) If dimensions are present from context, use them. b) If operand is a static constant rewritten as a literal, obtain the dimensions from the original declaration, otherwise use dimensions of type established from context. 2017-04-25 Yannick Moy * sem_util.adb (Is_Effectively_Volatile): Protect against base type of array that is private. From-SVN: r247209 --- gcc/ada/ChangeLog | 26 +++++++++++++++++++++++ gcc/ada/sem_dim.adb | 31 ++++++++++++++++++++++------ gcc/ada/sem_prag.adb | 8 ++++++-- gcc/ada/sem_util.adb | 16 +++++++++++---- gcc/ada/sem_warn.adb | 49 +++++++++++++++++++++++++++++++------------- 5 files changed, 104 insertions(+), 26 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index a3a79cd89cc..c13e016c551 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,29 @@ +2017-04-25 Claire Dross + + * sem_prag.adb (Collect_Inherited_Class_Wide_Conditions): Go to + ultimate alias when accessing overridden operation. Indeed, if the + overridden operation is itself inherited, it won't have any explicit + contract. + +2017-04-25 Ed Schonberg + + * sem_warn.adb (Warn_On_Overlapping_Actuals): There can be no + overlap if the two formals have different types, because formally + the corresponding actuals cannot designate the same objects. + +2017-04-25 Ed Schonberg + + * sem_dim.adb (Dimensions_Of_Operand): minot cleanups: a) If + dimensions are present from context, use them. b) If operand is + a static constant rewritten as a literal, obtain the dimensions + from the original declaration, otherwise use dimensions of type + established from context. + +2017-04-25 Yannick Moy + + * sem_util.adb (Is_Effectively_Volatile): Protect against base type + of array that is private. + 2017-04-25 Gary Dismukes * sem_ch3.adb, exp_util.adb, sem_prag.adb, exp_ch4.adb: Minor diff --git a/gcc/ada/sem_dim.adb b/gcc/ada/sem_dim.adb index d2edeebaede..1e956011d51 100644 --- a/gcc/ada/sem_dim.adb +++ b/gcc/ada/sem_dim.adb @@ -1343,7 +1343,11 @@ package body Sem_Dim is function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type; -- If the operand is a numeric literal that comes from a declared -- constant, use the dimensions of the constant which were computed - -- from the expression of the constant declaration. + -- from the expression of the constant declaration. Otherwise the + -- dimensions are those of the operand, or the type of the operand. + -- This takes care of node rewritings from validity checks, where the + -- dimensions of the operand itself may not be preserved, while the + -- type comes from context and must have dimension information. procedure Error_Dim_Msg_For_Binary_Op (N, L, R : Node_Id); -- Error using Error_Msg_NE and Error_Msg_N at node N. Output the @@ -1354,13 +1358,28 @@ package body Sem_Dim is --------------------------- function Dimensions_Of_Operand (N : Node_Id) return Dimension_Type is + Dims : constant Dimension_Type := Dimensions_Of (N); + begin - if Nkind (N) = N_Real_Literal - and then Present (Original_Entity (N)) - then - return Dimensions_Of (Original_Entity (N)); + if Exists (Dims) then + return Dims; + + elsif Is_Entity_Name (N) then + return Dimensions_Of (Etype (Entity (N))); + + elsif Nkind (N) = N_Real_Literal then + + if Present (Original_Entity (N)) then + return Dimensions_Of (Original_Entity (N)); + + else + return Dimensions_Of (Etype (N)); + end if; + + -- Otherwise return the default dimensions + else - return Dimensions_Of (N); + return Dims; end if; end Dimensions_Of_Operand; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 53f6b42d7e5..acaacf88566 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -27915,8 +27915,12 @@ package body Sem_Prag is --------------------------------------------- procedure Collect_Inherited_Class_Wide_Conditions (Subp : Entity_Id) is - Parent_Subp : constant Entity_Id := Overridden_Operation (Subp); - Prags : constant Node_Id := Contract (Parent_Subp); + Parent_Subp : constant Entity_Id := + Ultimate_Alias (Overridden_Operation (Subp)); + -- The Overridden_Operation may itself be inherited and as such have no + -- explicit contract. + + Prags : constant Node_Id := Contract (Parent_Subp); In_Spec_Expr : Boolean; Installed : Boolean; Prag : Node_Id; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 753098c0c1a..1cae279da0b 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -12805,10 +12805,18 @@ package body Sem_Util is -- effectively volatile. elsif Is_Array_Type (Id) then - return - Has_Volatile_Components (Id) - or else - Is_Effectively_Volatile (Component_Type (Base_Type (Id))); + declare + Anc : Entity_Id := Base_Type (Id); + begin + if Ekind (Anc) in Private_Kind then + Anc := Full_View (Anc); + end if; + + return + Has_Volatile_Components (Id) + or else + Is_Effectively_Volatile (Component_Type (Anc)); + end; -- A protected type is always volatile diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 29bdfd4886f..6e8032c855c 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -3487,13 +3487,12 @@ package body Sem_Warn is --------------------------------- procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is - Act1, Act2 : Node_Id; - Form1, Form2 : Entity_Id; - function Is_Covered_Formal (Formal : Node_Id) return Boolean; -- Return True if Formal is covered by the rule - function Refer_Same_Object (Act1, Act2 : Node_Id) return Boolean; + function Refer_Same_Object + (Act1 : Node_Id; + Act2 : Node_Id) return Boolean; -- Two names are known to refer to the same object if the two names -- are known to denote the same object; or one of the names is a -- selected_component, indexed_component, or slice and its prefix is @@ -3502,16 +3501,6 @@ package body Sem_Warn is -- object_name is known to refer to the same object as the other name -- (RM 6.4.1(6.11/3)) - ----------------------- - -- Refer_Same_Object -- - ----------------------- - - function Refer_Same_Object (Act1, Act2 : Node_Id) return Boolean is - begin - return Denotes_Same_Object (Act1, Act2) - or else Denotes_Same_Prefix (Act1, Act2); - end Refer_Same_Object; - ----------------------- -- Is_Covered_Formal -- ----------------------- @@ -3525,7 +3514,31 @@ package body Sem_Warn is or else Is_Array_Type (Etype (Formal))); end Is_Covered_Formal; + ----------------------- + -- Refer_Same_Object -- + ----------------------- + + function Refer_Same_Object + (Act1 : Node_Id; + Act2 : Node_Id) return Boolean + is + begin + return + Denotes_Same_Object (Act1, Act2) + or else Denotes_Same_Prefix (Act1, Act2); + end Refer_Same_Object; + + -- Local variables + + Act1 : Node_Id; + Act2 : Node_Id; + Form1 : Entity_Id; + Form2 : Entity_Id; + + -- Start of processing for Warn_On_Overlapping_Actuals + begin + if Ada_Version < Ada_2012 and then not Warn_On_Overlap then return; end if; @@ -3593,6 +3606,14 @@ package body Sem_Warn is then null; + -- If the types of the formals are different there can + -- be no aliasing (even though there might be overlap + -- through address clauses, which must be intentional). + + elsif Base_Type (Etype (Form1)) /= Base_Type (Etype (Form2)) + then + null; + -- Here we may need to issue overlap message else -- 2.30.2