public inbox for gcc-cvs@sourceware.org
help / color / mirror / Atom feed
* [gcc r13-600] [Ada] Ada2022: AI12-0143 Index attribute for entry families
@ 2022-05-18 8:44 Pierre-Marie de Rodat
0 siblings, 0 replies; only message in thread
From: Pierre-Marie de Rodat @ 2022-05-18 8:44 UTC (permalink / raw)
To: gcc-cvs
https://gcc.gnu.org/g:337c80a6bcf248f021e9731bba7543fb5bfb3553
commit r13-600-g337c80a6bcf248f021e9731bba7543fb5bfb3553
Author: Javier Miranda <miranda@adacore.com>
Date: Fri Apr 1 20:06:27 2022 +0000
[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.
Diff:
---
gcc/ada/einfo.ads | 3 +-
gcc/ada/exp_attr.adb | 18 ++++
gcc/ada/sem_attr.adb | 250 ++++++++++++++++++++++++++++++++++++++++++++++++
gcc/ada/sem_ch9.adb | 72 ++++++++++++++
gcc/ada/snames.ads-tmpl | 2 +
5 files changed, 344 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 9fed73d92a4..3f990c3b831 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -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
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index daab82fe11a..19aea23771a 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -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 --
-----------------
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index c7cb3329c04..4b00ea8f07d 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -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 --
----------------
diff --git a/gcc/ada/sem_ch9.adb b/gcc/ada/sem_ch9.adb
index c27de574bb0..2f8f01bcc91 100644
--- a/gcc/ada/sem_ch9.adb
+++ b/gcc/ada/sem_ch9.adb
@@ -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.
diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl
index cbcb1cf0e37..73e730446e4 100644
--- a/gcc/ada/snames.ads-tmpl
+++ b/gcc/ada/snames.ads-tmpl
@@ -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,
^ permalink raw reply [flat|nested] only message in thread
only message in thread, other threads:[~2022-05-18 8:44 UTC | newest]
Thread overview: (only message) (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2022-05-18 8:44 [gcc r13-600] [Ada] Ada2022: AI12-0143 Index attribute for entry families Pierre-Marie de Rodat
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).