diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads index d8931004fda..425d210b0e3 100644 --- a/gcc/ada/aspects.ads +++ b/gcc/ada/aspects.ads @@ -229,6 +229,16 @@ package Aspects is Aspect_Id range Aspect_Id'Succ (No_Aspect) .. Aspect_Id'Last; -- Aspect_Id's excluding No_Aspect + subtype Nonoverridable_Aspect_Id is Aspect_Id with + Static_Predicate => Nonoverridable_Aspect_Id in + Aspect_Default_Iterator | Aspect_Iterator_Element | + Aspect_Implicit_Dereference | Aspect_Constant_Indexing | + Aspect_Variable_Indexing | Aspect_Aggregate | + Aspect_Max_Entry_Queue_Length + -- | Aspect_No_Controlled_Parts + -- ??? No_Controlled_Parts not yet in Aspect_Id enumeration + ; -- see RM 13.1.1(18.7) + -- The following array indicates aspects that accept 'Class Class_Aspect_OK : constant array (Aspect_Id) of Boolean := diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index fbddfc9aaa0..27faac2de12 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -4159,7 +4159,7 @@ package body Sem_Ch13 is when Aspect_Aggregate => Validate_Aspect_Aggregate (Expr); Record_Rep_Item (E, Aspect); - return; + goto Continue; when Aspect_Integer_Literal | Aspect_Real_Literal @@ -4751,9 +4751,39 @@ package body Sem_Ch13 is Insert_After (Ins_Node, Aitem); Ins_Node := Aitem; end if; + + <> + + -- If a nonoverridable aspect is explicitly specified for a + -- derived type, then check consistency with the parent type. + + if A_Id in Nonoverridable_Aspect_Id + and then Nkind (N) = N_Full_Type_Declaration + and then Nkind (Type_Definition (N)) = N_Derived_Type_Definition + and then not In_Instance_Body + then + declare + Parent_Type : constant Entity_Id := Etype (E); + Inherited_Aspect : constant Node_Id := + Find_Aspect (Parent_Type, A_Id); + begin + if Present (Inherited_Aspect) + and then not Is_Confirming + (A_Id, Inherited_Aspect, Aspect) + then + Error_Msg_Name_1 := Aspect_Names (A_Id); + Error_Msg_Sloc := Sloc (Inherited_Aspect); + + Error_Msg + ("overriding aspect specification for " + & "nonoverridable aspect % does not confirm " + & "aspect specification inherited from #", + Sloc (Aspect)); + end if; + end; + end if; end Analyze_One_Aspect; - <> Next (Aspect); end loop Aspect_Loop; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index e103793f14b..cea12f22661 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -16754,6 +16754,14 @@ package body Sem_Ch3 is Next (Intf); end loop; end; + + -- Check consistency of any nonoverridable aspects that are + -- inherited from multiple sources. + + Check_Inherited_Nonoverridable_Aspects + (Inheritor => T, + Interface_List => Interface_List (Def), + Parent_Type => Parent_Type); end if; if Parent_Type = Any_Type diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb index 8f0ac17b6a8..fd3a29cfcbd 100644 --- a/gcc/ada/sem_ch9.adb +++ b/gcc/ada/sem_ch9.adb @@ -3532,6 +3532,14 @@ package body Sem_Ch9 is Next (Iface); end loop; + + -- Check consistency of any nonoverridable aspects that are + -- inherited from multiple sources. + + Check_Inherited_Nonoverridable_Aspects + (Inheritor => N, + Interface_List => Interface_List (N), + Parent_Type => Empty); end if; if not Has_Private_Declaration (T) then diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index a08ffeb2010..7a83d655fb1 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -25,7 +25,6 @@ with Treepr; -- ???For debugging code below -with Aspects; use Aspects; with Casing; use Casing; with Checks; use Checks; with Debug; use Debug; @@ -53,6 +52,7 @@ with Sem_Attr; use Sem_Attr; with Sem_Cat; use Sem_Cat; with Sem_Ch6; use Sem_Ch6; with Sem_Ch8; use Sem_Ch8; +with Sem_Ch13; use Sem_Ch13; with Sem_Disp; use Sem_Disp; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; @@ -4142,6 +4142,132 @@ package body Sem_Util is end if; end Check_No_Hidden_State; + --------------------------------------------- + -- Check_Nonoverridable_Aspect_Consistency -- + --------------------------------------------- + + procedure Check_Inherited_Nonoverridable_Aspects + (Inheritor : Entity_Id; + Interface_List : List_Id; + Parent_Type : Entity_Id) is + + -- array needed for iterating over subtype values + Nonoverridable_Aspects : constant array (Positive range <>) of + Nonoverridable_Aspect_Id := + (Aspect_Default_Iterator, + Aspect_Iterator_Element, + Aspect_Implicit_Dereference, + Aspect_Constant_Indexing, + Aspect_Variable_Indexing, + Aspect_Aggregate, + Aspect_Max_Entry_Queue_Length + -- , Aspect_No_Controlled_Parts + ); + + -- Note that none of these 8 aspects can be specified (for a type) + -- via a pragma. For 7 of them, the corresponding pragma does not + -- exist. The Pragma_Id enumeration type does include + -- Pragma_Max_Entry_Queue_Length, but that pragma is only use to + -- specify the aspect for a protected entry or entry family, not for + -- a type, and therefore cannot introduce the sorts of inheritance + -- issues that we are concerned with in this procedure. + + type Entity_Array is array (Nat range <>) of Entity_Id; + + function Ancestor_Entities return Entity_Array; + -- Returns all progenitors (including parent type, if present) + + procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors + (Aspect : Nonoverridable_Aspect_Id; + Ancestor_1 : Entity_Id; + Aspect_Spec_1 : Node_Id; + Ancestor_2 : Entity_Id; + Aspect_Spec_2 : Node_Id); + -- A given aspect has been specified for each of two ancestors; + -- check that the two aspect specifications are compatible (see + -- RM 13.1.1(18.5) and AI12-0211). + + ----------------------- + -- Ancestor_Entities -- + ----------------------- + + function Ancestor_Entities return Entity_Array is + Ifc_Count : constant Nat := List_Length (Interface_List); + Ifc_Ancestors : Entity_Array (1 .. Ifc_Count); + Ifc : Node_Id := First (Interface_List); + begin + for Idx in Ifc_Ancestors'Range loop + Ifc_Ancestors (Idx) := Entity (Ifc); + pragma Assert (Present (Ifc_Ancestors (Idx))); + Ifc := Next (Ifc); + end loop; + pragma Assert (not Present (Ifc)); + if Present (Parent_Type) then + return Parent_Type & Ifc_Ancestors; + else + return Ifc_Ancestors; + end if; + end Ancestor_Entities; + + ------------------------------------------------------- + -- Check_Consistency_For_One_Aspect_Of_Two_Ancestors -- + ------------------------------------------------------- + + procedure Check_Consistency_For_One_Aspect_Of_Two_Ancestors + (Aspect : Nonoverridable_Aspect_Id; + Ancestor_1 : Entity_Id; + Aspect_Spec_1 : Node_Id; + Ancestor_2 : Entity_Id; + Aspect_Spec_2 : Node_Id) is + begin + if not Is_Confirming (Aspect, Aspect_Spec_1, Aspect_Spec_2) then + Error_Msg_Name_1 := Aspect_Names (Aspect); + Error_Msg_Name_2 := Chars (Ancestor_1); + Error_Msg_Name_3 := Chars (Ancestor_2); + + Error_Msg ( + "incompatible % aspects inherited from ancestors % and %", + Sloc (Inheritor)); + end if; + end Check_Consistency_For_One_Aspect_Of_Two_Ancestors; + + Ancestors : constant Entity_Array := Ancestor_Entities; + + -- start of processing for Check_Inherited_Nonoverridable_Aspects + begin + -- No Ada_Version check here; AI12-0211 is a binding interpretation. + + if Ancestors'Length < 2 then + return; -- Inconsistency impossible; it takes 2 to disagree. + elsif In_Instance_Body then + return; -- No legality checking in an instance body. + end if; + + for Aspect of Nonoverridable_Aspects loop + declare + First_Ancestor_With_Aspect : Entity_Id := Empty; + First_Aspect_Spec, Current_Aspect_Spec : Node_Id := Empty; + begin + for Ancestor of Ancestors loop + Current_Aspect_Spec := Find_Aspect (Ancestor, Aspect); + if Present (Current_Aspect_Spec) then + if Present (First_Ancestor_With_Aspect) then + Check_Consistency_For_One_Aspect_Of_Two_Ancestors + (Aspect => Aspect, + Ancestor_1 => First_Ancestor_With_Aspect, + Aspect_Spec_1 => First_Aspect_Spec, + Ancestor_2 => Ancestor, + Aspect_Spec_2 => Current_Aspect_Spec); + else + First_Ancestor_With_Aspect := Ancestor; + First_Aspect_Spec := Current_Aspect_Spec; + end if; + end if; + end loop; + end; + end loop; + end Check_Inherited_Nonoverridable_Aspects; + ---------------------------------------- -- Check_Nonvolatile_Function_Profile -- ---------------------------------------- @@ -15265,6 +15391,120 @@ package body Sem_Util is return False; end Is_Child_Or_Sibling; + ------------------- + -- Is_Confirming -- + ------------------- + + function Is_Confirming (Aspect : Nonoverridable_Aspect_Id; + Aspect_Spec_1, Aspect_Spec_2 : Node_Id) + return Boolean is + function Names_Match (Nm1, Nm2 : Node_Id) return Boolean; + function Names_Match (Nm1, Nm2 : Node_Id) return Boolean is + begin + if Nkind (Nm1) /= Nkind (Nm2) then + return False; + end if; + case Nkind (Nm1) is + when N_Identifier => + return Name_Equals (Chars (Nm1), Chars (Nm2)); + when N_Expanded_Name => + return Names_Match (Prefix (Nm1), Prefix (Nm2)) + and then Names_Match (Selector_Name (Nm1), + Selector_Name (Nm2)); + when N_Empty => + return True; -- needed for Aggregate aspect checking + + when others => + -- e.g., 'Class attribute references + if Is_Entity_Name (Nm1) and Is_Entity_Name (Nm2) then + return Entity (Nm1) = Entity (Nm2); + end if; + + raise Program_Error; + end case; + end Names_Match; + begin + -- allow users to disable "shall be confirming" check, at least for now + if Relaxed_RM_Semantics then + return True; + end if; + + -- ??? Type conversion here (along with "when others =>" below) is a + -- workaround for a bootstrapping problem related to casing on a + -- static-predicate-bearing subtype. + + case Aspect_Id (Aspect) is + -- name-valued aspects; compare text of names, not resolution. + when Aspect_Default_Iterator + | Aspect_Iterator_Element + | Aspect_Constant_Indexing + | Aspect_Variable_Indexing + | Aspect_Implicit_Dereference => + declare + Item_1 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_1); + Item_2 : constant Node_Id := Aspect_Rep_Item (Aspect_Spec_2); + begin + if (Nkind (Item_1) /= N_Attribute_Definition_Clause) + or (Nkind (Item_2) /= N_Attribute_Definition_Clause) + then + pragma Assert (Serious_Errors_Detected > 0); + return True; + end if; + + return Names_Match (Expression (Item_1), + Expression (Item_2)); + end; + + -- one of a kind + when Aspect_Aggregate => + declare + Empty_1, + Add_Named_1, + Add_Unnamed_1, + New_Indexed_1, + Assign_Indexed_1, + Empty_2, + Add_Named_2, + Add_Unnamed_2, + New_Indexed_2, + Assign_Indexed_2 : Node_Id := Empty; + begin + Parse_Aspect_Aggregate + (N => Expression (Aspect_Spec_1), + Empty_Subp => Empty_1, + Add_Named_Subp => Add_Named_1, + Add_Unnamed_Subp => Add_Unnamed_1, + New_Indexed_Subp => New_Indexed_1, + Assign_Indexed_Subp => Assign_Indexed_1); + Parse_Aspect_Aggregate + (N => Expression (Aspect_Spec_2), + Empty_Subp => Empty_2, + Add_Named_Subp => Add_Named_2, + Add_Unnamed_Subp => Add_Unnamed_2, + New_Indexed_Subp => New_Indexed_2, + Assign_Indexed_Subp => Assign_Indexed_2); + return + Names_Match (Empty_1, Empty_2) and then + Names_Match (Add_Named_1, Add_Named_2) and then + Names_Match (Add_Unnamed_1, Add_Unnamed_2) and then + Names_Match (New_Indexed_1, New_Indexed_2) and then + Names_Match (Assign_Indexed_1, Assign_Indexed_2); + end; + + -- scalar-valued aspects; compare (static) values. + when Aspect_Max_Entry_Queue_Length -- | Aspect_No_Controlled_Parts + => + -- This should be unreachable. No_Controlled_Parts is + -- not yet supported at all in GNAT and Max_Entry_Queue_Length + -- is supported only for protected entries, not for types. + pragma Assert (Serious_Errors_Detected /= 0); + return True; + + when others => + raise Program_Error; + end case; + end Is_Confirming; + ----------------------------- -- Is_Concurrent_Interface -- ----------------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index bcc7fd7271a..2b49a44db7a 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -25,6 +25,7 @@ -- Package containing utility procedures used throughout the semantics +with Aspects; use Aspects; with Atree; use Atree; with Einfo; use Einfo; with Exp_Tss; use Exp_Tss; @@ -413,6 +414,17 @@ package Sem_Util is -- Determine whether object or state Id introduces a hidden state. If this -- is the case, emit an error. + procedure Check_Inherited_Nonoverridable_Aspects + (Inheritor : Entity_Id; + Interface_List : List_Id; + Parent_Type : Entity_Id); + -- Verify consistency of inherited nonoverridable aspects + -- when aspects are inherited from more than one source. + -- Parent_Type may be void (e.g., for a tagged task/protected type + -- whose declaration includes a non-empty interface list). + -- In the error case, error message is associate with Inheritor; + -- Inheritor parameter is otherwise unused. + procedure Check_Nonvolatile_Function_Profile (Func_Id : Entity_Id); -- Verify that the profile of nonvolatile function Func_Id does not contain -- effectively volatile parameters or return type for reading. @@ -1685,6 +1697,12 @@ package Sem_Util is -- Determine whether entity Id denotes a procedure with synchronization -- kind By_Protected_Procedure. + function Is_Confirming (Aspect : Nonoverridable_Aspect_Id; + Aspect_Spec_1, Aspect_Spec_2 : Node_Id) + return Boolean; + -- Returns true if the two specifications of the given + -- nonoverridable aspect are compatible. + function Is_Constant_Bound (Exp : Node_Id) return Boolean; -- Exp is the expression for an array bound. Determines whether the -- bound is a compile-time known value, or a constant entity, or an