[Ada] Ada2022: AI12-0143 Index attribute for entry families
gcc/ada/ * snames.ads-tmpl (Name_Index): New attribute name. (Attribute_Id): Adding Attribute_Index as regular attribute. * sem_attr.adb (Attribute_22): Adding Attribute_Index as Ada 2022 attribute. (Analyze_Index_Attribute): Check that 'Index appears in a pre-/postcondition aspect or pragma associated with an entry family. (Analyze_Attribute): Adding semantic analysis for 'Index. (Eval_Attribute): Register 'Index as can never be folded. (Resolve_Attribute): Resolve attribute 'Index. * sem_ch9.adb (Check_Wrong_Attribute_In_Postconditions): New subprogram. (Analyze_Requeue): Check that the requeue target shall not have an applicable specific or class-wide postcondition which includes an Index attribute reference. * exp_attr.adb (Expand_N_Attribute_Reference): Transform attribute Index into a renaming of the second formal of the wrapper built for an entry family that has contract cases. * einfo.ads (Is_Entry_Wrapper): Complete documentation.
This commit is contained in:
Javier Miranda
Pierre-Marie de Rodat
parent
3c63f73051
commit
337c80a6bc
|
|
@ -2599,7 +2599,8 @@ package Einfo is
|
|||
-- test for the need to replace references in Exp_Ch2.
|
||||
|
||||
-- Is_Entry_Wrapper
|
||||
-- Defined on wrappers created for entries that have precondition aspects
|
||||
-- Defined on wrappers created for entries that have precondition or
|
||||
-- postcondition aspects.
|
||||
|
||||
-- Is_Enumeration_Type (synthesized)
|
||||
-- Defined in all entities, true for enumeration types and subtypes
|
||||
|
|
|
|||
|
|
@ -3995,6 +3995,24 @@ package body Exp_Attr is
|
|||
when Attribute_Img =>
|
||||
Exp_Imgv.Expand_Image_Attribute (N);
|
||||
|
||||
-----------
|
||||
-- Index --
|
||||
-----------
|
||||
|
||||
-- Transforms 'Index attribute into a reference to the second formal of
|
||||
-- the wrapper built for an entry family that has contract cases (see
|
||||
-- Exp_Ch9.Build_Contract_Wrapper).
|
||||
|
||||
when Attribute_Index => Index : declare
|
||||
Entry_Id : constant Entity_Id := Entity (Pref);
|
||||
Entry_Idx : constant Entity_Id :=
|
||||
Next_Entity
|
||||
(First_Entity (Contract_Wrapper (Entry_Id)));
|
||||
begin
|
||||
Rewrite (N, New_Occurrence_Of (Entry_Idx, Loc));
|
||||
Analyze_And_Resolve (N, Typ);
|
||||
end Index;
|
||||
|
||||
-----------------
|
||||
-- Initialized --
|
||||
-----------------
|
||||
|
|
|
|||
|
|
@ -176,6 +176,7 @@ package body Sem_Attr is
|
|||
Attribute_22 : constant Attribute_Class_Array := Attribute_Class_Array'(
|
||||
Attribute_Enum_Rep |
|
||||
Attribute_Enum_Val => True,
|
||||
Attribute_Index => True,
|
||||
Attribute_Preelaborable_Initialization => True,
|
||||
others => False);
|
||||
|
||||
|
|
@ -276,6 +277,15 @@ package body Sem_Attr is
|
|||
-- sets the type of the attribute to the one specified by Str_Typ (e.g.
|
||||
-- Standard_String for 'Image and Standard_Wide_String for 'Wide_Image).
|
||||
|
||||
procedure Analyze_Index_Attribute
|
||||
(Legal : out Boolean;
|
||||
Spec_Id : out Entity_Id);
|
||||
-- Processing for attribute 'Index. It checks that the attribute appears
|
||||
-- in a pre/postcondition-like aspect or pragma associated with an entry
|
||||
-- family. Flag Legal is set when the above criteria are met. Spec_Id
|
||||
-- denotes the entity of the wrapper of the entry family or Empty if
|
||||
-- the attribute is illegal.
|
||||
|
||||
procedure Bad_Attribute_For_Predicate;
|
||||
-- Output error message for use of a predicate (First, Last, Range) not
|
||||
-- allowed with a type that has predicates. If the type is a generic
|
||||
|
|
@ -1585,6 +1595,178 @@ package body Sem_Attr is
|
|||
end if;
|
||||
end Analyze_Image_Attribute;
|
||||
|
||||
-----------------------------
|
||||
-- Analyze_Index_Attribute --
|
||||
-----------------------------
|
||||
|
||||
procedure Analyze_Index_Attribute
|
||||
(Legal : out Boolean;
|
||||
Spec_Id : out Entity_Id)
|
||||
is
|
||||
procedure Check_Placement_In_Check (Prag : Node_Id);
|
||||
-- Verify that the attribute appears within pragma Check that mimics
|
||||
-- a postcondition.
|
||||
|
||||
procedure Placement_Error;
|
||||
pragma No_Return (Placement_Error);
|
||||
-- Emit a general error when the attributes does not appear in a
|
||||
-- precondition or postcondition aspect or pragma, and then raises
|
||||
-- Bad_Attribute to avoid any further semantic processing.
|
||||
|
||||
------------------------------
|
||||
-- Check_Placement_In_Check --
|
||||
------------------------------
|
||||
|
||||
procedure Check_Placement_In_Check (Prag : Node_Id) is
|
||||
Args : constant List_Id := Pragma_Argument_Associations (Prag);
|
||||
Nam : constant Name_Id := Chars (Get_Pragma_Arg (First (Args)));
|
||||
|
||||
begin
|
||||
-- The "Name" argument of pragma Check denotes a precondition or
|
||||
-- postcondition.
|
||||
|
||||
if Nam in Name_Post
|
||||
| Name_Postcondition
|
||||
| Name_Pre
|
||||
| Name_Precondition
|
||||
| Name_Refined_Post
|
||||
then
|
||||
null;
|
||||
|
||||
-- Otherwise the placement of the attribute is illegal
|
||||
|
||||
else
|
||||
Placement_Error;
|
||||
end if;
|
||||
end Check_Placement_In_Check;
|
||||
|
||||
---------------------
|
||||
-- Placement_Error --
|
||||
---------------------
|
||||
|
||||
procedure Placement_Error is
|
||||
begin
|
||||
Error_Attr
|
||||
("attribute % can only appear in pre- or postcondition", P);
|
||||
end Placement_Error;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Prag : Node_Id;
|
||||
Prag_Nam : Name_Id;
|
||||
Subp_Decl : Node_Id;
|
||||
|
||||
-- Start of processing for Analyze_Index_Attribute
|
||||
|
||||
begin
|
||||
-- Assume that the attribute is illegal
|
||||
|
||||
Legal := False;
|
||||
Spec_Id := Empty;
|
||||
|
||||
-- Skip processing during preanalysis of class-wide preconditions and
|
||||
-- postconditions since at this stage the expression is not installed
|
||||
-- yet on its definite context.
|
||||
|
||||
if Inside_Class_Condition_Preanalysis then
|
||||
Legal := True;
|
||||
Spec_Id := Current_Scope;
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Traverse the parent chain to find the aspect or pragma where the
|
||||
-- attribute resides.
|
||||
|
||||
Prag := N;
|
||||
while Present (Prag) loop
|
||||
if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
|
||||
exit;
|
||||
|
||||
-- Prevent the search from going too far
|
||||
|
||||
elsif Is_Body_Or_Package_Declaration (Prag) then
|
||||
exit;
|
||||
end if;
|
||||
|
||||
Prag := Parent (Prag);
|
||||
end loop;
|
||||
|
||||
-- The attribute is allowed to appear only in precondition and
|
||||
-- postcondition-like aspects or pragmas.
|
||||
|
||||
if Nkind (Prag) in N_Aspect_Specification | N_Pragma then
|
||||
if Nkind (Prag) = N_Aspect_Specification then
|
||||
Prag_Nam := Chars (Identifier (Prag));
|
||||
else
|
||||
Prag_Nam := Pragma_Name (Prag);
|
||||
end if;
|
||||
|
||||
if Prag_Nam = Name_Check then
|
||||
Check_Placement_In_Check (Prag);
|
||||
|
||||
elsif Prag_Nam in Name_Post
|
||||
| Name_Postcondition
|
||||
| Name_Pre
|
||||
| Name_Precondition
|
||||
| Name_Refined_Post
|
||||
then
|
||||
null;
|
||||
|
||||
else
|
||||
Placement_Error;
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Otherwise the placement of the attribute is illegal
|
||||
|
||||
else
|
||||
Placement_Error;
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Find the related subprogram subject to the aspect or pragma
|
||||
|
||||
if Nkind (Prag) = N_Aspect_Specification then
|
||||
Subp_Decl := Parent (Prag);
|
||||
else
|
||||
Subp_Decl := Find_Related_Declaration_Or_Body (Prag);
|
||||
end if;
|
||||
|
||||
-- The aspect or pragma where the attribute resides should be
|
||||
-- associated with a subprogram declaration or a body since the
|
||||
-- analysis of pre-/postconditions of entry and entry families is
|
||||
-- performed in their wrapper subprogram. If this is not the case,
|
||||
-- then the aspect or pragma is illegal and no further analysis is
|
||||
-- required.
|
||||
|
||||
if Nkind (Subp_Decl) not in N_Subprogram_Body
|
||||
| N_Subprogram_Declaration
|
||||
then
|
||||
return;
|
||||
end if;
|
||||
|
||||
Spec_Id := Unique_Defining_Entity (Subp_Decl);
|
||||
|
||||
-- If we get here and Spec_Id denotes the entity of the entry wrapper
|
||||
-- (or the postcondition procedure of the entry wrapper) then the
|
||||
-- attribute is legal.
|
||||
|
||||
if Is_Entry_Wrapper (Spec_Id) then
|
||||
Legal := True;
|
||||
|
||||
elsif Chars (Spec_Id) = Name_uPostconditions
|
||||
and then Is_Entry_Wrapper (Scope (Spec_Id))
|
||||
then
|
||||
Spec_Id := Scope (Spec_Id);
|
||||
Legal := True;
|
||||
|
||||
-- Otherwise the attribute is illegal and we return Empty
|
||||
|
||||
else
|
||||
Spec_Id := Empty;
|
||||
end if;
|
||||
end Analyze_Index_Attribute;
|
||||
|
||||
---------------------------------
|
||||
-- Bad_Attribute_For_Predicate --
|
||||
---------------------------------
|
||||
|
|
@ -4279,6 +4461,55 @@ package body Sem_Attr is
|
|||
Check_Object_Reference (E1);
|
||||
Set_Etype (N, Standard_Boolean);
|
||||
|
||||
-----------
|
||||
-- Index --
|
||||
-----------
|
||||
|
||||
when Attribute_Index => Index : declare
|
||||
Ent : Entity_Id;
|
||||
Legal : Boolean;
|
||||
Spec_Id : Entity_Id;
|
||||
|
||||
begin
|
||||
Check_E0;
|
||||
Analyze_Index_Attribute (Legal, Spec_Id);
|
||||
|
||||
if not Legal or else No (Spec_Id) then
|
||||
Error_Attr ("attribute % must apply to entry family", P);
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- Legality checks
|
||||
|
||||
if Nkind (P) in N_Identifier | N_Expanded_Name then
|
||||
Ent := Entity (P);
|
||||
|
||||
if Ekind (Ent) /= E_Entry_Family then
|
||||
Error_Attr
|
||||
("attribute % must apply to entry family", P);
|
||||
|
||||
-- Analysis of pre/postconditions of an entry [family] occurs when
|
||||
-- the conditions are relocated to the contract wrapper procedure
|
||||
-- (see subprogram Build_Contract_Wrapper).
|
||||
|
||||
elsif Contract_Wrapper (Ent) /= Spec_Id then
|
||||
Error_Attr
|
||||
("attribute % must apply to current entry family", P);
|
||||
end if;
|
||||
|
||||
elsif Nkind (P) in N_Indexed_Component
|
||||
| N_Selected_Component
|
||||
then
|
||||
Error_Attr
|
||||
("attribute % must apply to current entry family", P);
|
||||
|
||||
else
|
||||
Error_Attr ("invalid entry family name", N);
|
||||
end if;
|
||||
|
||||
Set_Etype (N, Entry_Index_Type (Ent));
|
||||
end Index;
|
||||
|
||||
-----------------------
|
||||
-- Has_Tagged_Values --
|
||||
-----------------------
|
||||
|
|
@ -10595,6 +10826,7 @@ package body Sem_Attr is
|
|||
| Attribute_First_Bit
|
||||
| Attribute_Img
|
||||
| Attribute_Input
|
||||
| Attribute_Index
|
||||
| Attribute_Initialized
|
||||
| Attribute_Last_Bit
|
||||
| Attribute_Library_Level
|
||||
|
|
@ -12087,6 +12319,24 @@ package body Sem_Attr is
|
|||
when Attribute_Enabled =>
|
||||
null;
|
||||
|
||||
-----------
|
||||
-- Index --
|
||||
-----------
|
||||
|
||||
when Attribute_Index =>
|
||||
if Nkind (P) = N_Indexed_Component
|
||||
and then Is_Entity_Name (Prefix (P))
|
||||
then
|
||||
declare
|
||||
Indx : constant Node_Id := First (Expressions (P));
|
||||
Fam : constant Entity_Id := Entity (Prefix (P));
|
||||
|
||||
begin
|
||||
Resolve (Indx, Entry_Index_Type (Fam));
|
||||
Apply_Scalar_Range_Check (Indx, Entry_Index_Type (Fam));
|
||||
end;
|
||||
end if;
|
||||
|
||||
----------------
|
||||
-- Loop_Entry --
|
||||
----------------
|
||||
|
|
|
|||
|
|
@ -2293,6 +2293,64 @@ package body Sem_Ch9 is
|
|||
---------------------
|
||||
|
||||
procedure Analyze_Requeue (N : Node_Id) is
|
||||
|
||||
procedure Check_Wrong_Attribute_In_Postconditions
|
||||
(Entry_Id : Entity_Id;
|
||||
Error_Node : Node_Id);
|
||||
-- Check that the requeue target Entry_Id does not have an specific or
|
||||
-- class-wide postcondition that references an Old or Index attribute.
|
||||
|
||||
---------------------------------------------
|
||||
-- Check_Wrong_Attribute_In_Postconditions --
|
||||
---------------------------------------------
|
||||
|
||||
procedure Check_Wrong_Attribute_In_Postconditions
|
||||
(Entry_Id : Entity_Id;
|
||||
Error_Node : Node_Id)
|
||||
is
|
||||
function Check_Node (N : Node_Id) return Traverse_Result;
|
||||
-- Check that N is not a reference to attribute Index or Old; report
|
||||
-- an error otherwise.
|
||||
|
||||
----------------
|
||||
-- Check_Node --
|
||||
----------------
|
||||
|
||||
function Check_Node (N : Node_Id) return Traverse_Result is
|
||||
begin
|
||||
if Nkind (N) = N_Attribute_Reference
|
||||
and then Attribute_Name (N) in Name_Index
|
||||
| Name_Old
|
||||
then
|
||||
Error_Msg_Name_1 := Attribute_Name (N);
|
||||
Error_Msg_N
|
||||
("target of requeue must not have references to attribute % "
|
||||
& "in postcondition",
|
||||
Error_Node);
|
||||
end if;
|
||||
|
||||
return OK;
|
||||
end Check_Node;
|
||||
|
||||
procedure Check_Attr_Refs is new Traverse_Proc (Check_Node);
|
||||
|
||||
-- Local variables
|
||||
|
||||
Prag : Node_Id;
|
||||
begin
|
||||
Prag := Pre_Post_Conditions (Contract (Entry_Id));
|
||||
|
||||
while Present (Prag) loop
|
||||
if Pragma_Name (Prag) = Name_Postcondition then
|
||||
Check_Attr_Refs (First (Pragma_Argument_Associations (Prag)));
|
||||
end if;
|
||||
|
||||
Prag := Next_Pragma (Prag);
|
||||
end loop;
|
||||
end Check_Wrong_Attribute_In_Postconditions;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Count : Natural := 0;
|
||||
Entry_Name : Node_Id := Name (N);
|
||||
Entry_Id : Entity_Id;
|
||||
|
|
@ -2305,6 +2363,8 @@ package body Sem_Ch9 is
|
|||
Outer_Ent : Entity_Id;
|
||||
Synch_Type : Entity_Id := Empty;
|
||||
|
||||
-- Start of processing for Analyze_Requeue
|
||||
|
||||
begin
|
||||
-- Preserve relevant elaboration-related attributes of the context which
|
||||
-- are no longer available or very expensive to recompute once analysis,
|
||||
|
|
@ -2588,6 +2648,18 @@ package body Sem_Ch9 is
|
|||
("target protected object of requeue must be a variable", N);
|
||||
end if;
|
||||
|
||||
-- Ada 2022 (AI12-0143): The requeue target shall not have an
|
||||
-- applicable specific or class-wide postcondition which includes
|
||||
-- an Old or Index attribute reference.
|
||||
|
||||
if Ekind (Entry_Id) = E_Entry_Family
|
||||
and then Present (Contract (Entry_Id))
|
||||
then
|
||||
Check_Wrong_Attribute_In_Postconditions
|
||||
(Entry_Id => Entry_Id,
|
||||
Error_Node => Entry_Name);
|
||||
end if;
|
||||
|
||||
-- A requeue statement is treated as a call for purposes of ABE checks
|
||||
-- and diagnostics. Annotate the tree by creating a call marker in case
|
||||
-- the requeue statement is transformed by expansion.
|
||||
|
|
|
|||
|
|
@ -958,6 +958,7 @@ package Snames is
|
|||
Name_Has_Tagged_Values : constant Name_Id := N + $; -- GNAT
|
||||
Name_Identity : constant Name_Id := N + $;
|
||||
Name_Implicit_Dereference : constant Name_Id := N + $; -- GNAT
|
||||
Name_Index : constant Name_Id := N + $; -- Ada 22
|
||||
Name_Initialized : constant Name_Id := N + $; -- GNAT
|
||||
Name_Integer_Value : constant Name_Id := N + $; -- GNAT
|
||||
Name_Invalid_Value : constant Name_Id := N + $; -- GNAT
|
||||
|
|
@ -1480,6 +1481,7 @@ package Snames is
|
|||
Attribute_Has_Tagged_Values,
|
||||
Attribute_Identity,
|
||||
Attribute_Implicit_Dereference,
|
||||
Attribute_Index,
|
||||
Attribute_Initialized,
|
||||
Attribute_Integer_Value,
|
||||
Attribute_Invalid_Value,
|
||||
|
|
|
|||
Loading…
Reference in New Issue