AI12-0211 introduces two new legality rules. The first says that if a
nonoverridable aspect is explicitly specified for a type which also
inherits that aspect from another type (an ancestor or a progenitor),
then the explicit aspect specification shall be confirming. The second
says that if a type inherits a nonoverridable aspect from two different
sources (this can only occur if at least one of the two is an interface
type), then the two sources shall agree with respect to the given
aspect. Implement these new legality checks. This AI is a binding
interpretation, so these checks are performed even for pre-Ada202x Ada
versions.
Tested on x86_64-pc-linux-gnu, committed on trunk
gcc/ada/
* aspects.ads: Introduce the subtype Nonoverridable_Aspect_Id,
whose Static_Predicate reflects the list of nonoverridable
aspects given in Ada RM 13.1.1(18.7).
* sem_util.ads, sem_util.adb: Add two new visible subprograms,
Check_Inherited_Nonoverridable_Aspects and Is_Confirming. The
former is used to check the consistency of inherited
nonoverridable aspects from multiple sources. The latter
indicates whether two aspect specifications for a nonoverridable
aspect are confirming. Because of compatibility concerns in
compiling QGen, Is_Confirming always returns True if
Relaxed_RM_Semantics (i.e., -gnatd.M) is specified.
* sem_ch3.adb (Derived_Type_Declaration): Call new
Check_Inherited_Nonoverridable_Aspects procedure if interface
list is non-empty.
* sem_ch9.adb (Check_Interfaces): Call new
Check_Inherited_Nonoverridable_Aspects procedure if interface
list is non-empty.
* sem_ch13.adb (Analyze_Aspect_Specifications): When an explicit
aspect specification overrides an inherited nonoverridable
aspect, check that the explicit specification is confirming.diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
--- 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
--- 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;
+
+ <<Continue>>
+
+ -- 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;
- <<Continue>>
Next (Aspect);
end loop Aspect_Loop;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
--- 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
--- 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
--- 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
--- 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
