From 337c80a6bcf248f021e9731bba7543fb5bfb3553 Mon Sep 17 00:00:00 2001 From: Javier Miranda Date: Fri, 1 Apr 2022 20:06:27 +0000 Subject: [PATCH] [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. --- 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 9fed73d..3f990c3 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 daab82f..19aea23 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 c7cb3329..4b00ea8 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 c27de57..2f8f01b 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 cbcb1cf..73e7304 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, -- 2.7.4