From 7b6a7ef8ad0e180b2f12b2a1535b31d0acc83f1c Mon Sep 17 00:00:00 2001 From: Ed Schonberg Date: Sun, 12 Apr 2020 10:34:46 -0400 Subject: [PATCH] [Ada] Ada_2020 AI12-0220 Pre/Postconditions on Access_To_Subprogram types 2020-06-17 Ed Schonberg gcc/ada/ * sem_ch3.adb (Analyze_Full_Type_Declaration): For an access_to_subprogram declaration that has aspect specifications, call Build_Access_ Subprogram_Wrapper at once, so that pre- and postcondition aspects are analyzed in the context of a subprogram declaration. (Build_Access_Subprogram_Wrapper): Examine aspect specifications of an Access_To_Subprogram declaration. If pre- or postconditions are declared for it, create declaration for subprogram wrapper and add the corresponding aspect specifications to it. Replace occurrences of the type name by that of the generated subprogram, so that attributes 'Old and 'Result can appear in a postcondition. * exp_ch3.adb (Build_Access_Subprogram_Wrapper_Body): Moved here from sem_prag.adb. * exp_ch3.ads (Build_Access_Subprogram_Wrapper_Body): Visible subprogram. * sem_prag.adb (Build_Access_Subprogram_Wrapper / _Body): Moved to sem_ch3.adb and exp_ch3.adb. --- gcc/ada/exp_ch3.adb | 72 ++++++++++++++++ gcc/ada/exp_ch3.ads | 11 +++ gcc/ada/sem_ch3.adb | 156 ++++++++++++++++++++++++++++++++++ gcc/ada/sem_prag.adb | 193 +------------------------------------------ 4 files changed, 243 insertions(+), 189 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b207a1f1c92..6e1e6251d10 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -515,6 +515,78 @@ package body Exp_Ch3 is end loop; end Adjust_Discriminants; + ------------------------------------------ + -- Build_Access_Subprogram_Wrapper_Body -- + ------------------------------------------ + + procedure Build_Access_Subprogram_Wrapper_Body + (Decl : Node_Id; + New_Decl : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Decl); + Actuals : constant List_Id := New_List; + Type_Def : constant Node_Id := Type_Definition (Decl); + Type_Id : constant Entity_Id := Defining_Identifier (Decl); + Spec_Node : constant Node_Id := + New_Copy_Tree (Specification (New_Decl)); + + Act : Node_Id; + Body_Node : Node_Id; + Call_Stmt : Node_Id; + Ptr : Entity_Id; + begin + if not Expander_Active then + return; + end if; + + Set_Defining_Unit_Name (Spec_Node, + Make_Defining_Identifier + (Loc, Chars (Defining_Unit_Name (Spec_Node)))); + + -- Create List of actuals for indirect call. The last + -- parameter of the subprogram is the access value itself. + + Act := First (Parameter_Specifications (Spec_Node)); + + while Present (Act) loop + Append_To (Actuals, + Make_Identifier (Loc, Chars (Defining_Identifier (Act)))); + Next (Act); + exit when Act = Last (Parameter_Specifications (Spec_Node)); + end loop; + + Ptr := + Defining_Identifier + (Last (Parameter_Specifications (Spec_Node))); + + if Nkind (Type_Def) = N_Access_Procedure_Definition then + Call_Stmt := Make_Procedure_Call_Statement (Loc, + Name => + Make_Explicit_Dereference + (Loc, New_Occurrence_Of (Ptr, Loc)), + Parameter_Associations => Actuals); + else + Call_Stmt := Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => Make_Explicit_Dereference + (Loc, New_Occurrence_Of (Ptr, Loc)), + Parameter_Associations => Actuals)); + end if; + + Body_Node := Make_Subprogram_Body (Loc, + Specification => Spec_Node, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call_Stmt))); + + -- Place body in list of freeze actions for the type. + + Ensure_Freeze_Node (Type_Id); + Append_Freeze_Actions (Type_Id, New_List (Body_Node)); + end Build_Access_Subprogram_Wrapper_Body; + --------------------------- -- Build_Array_Init_Proc -- --------------------------- diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads index 3ac7c9b6266..12387cfcca4 100644 --- a/gcc/ada/exp_ch3.ads +++ b/gcc/ada/exp_ch3.ads @@ -46,6 +46,17 @@ package Exp_Ch3 is procedure Expand_Record_Extension (T : Entity_Id; Def : Node_Id); -- Add a field _parent in the extension part of the record + procedure Build_Access_Subprogram_Wrapper_Body + (Decl : Node_Id; + New_Decl : Node_Id); + -- Build the wrapper body, which holds the indirect call through + -- an access_to_subprogram, and whose expansion incorporates the + -- contracts of the access type declaration. Called from Build_ + -- Access_Subprogram_Wrapper. + -- Building the wrapper is done during analysis to perform proper + -- semantic checks on the relevant aspects. The wrapper body could + -- be simplified to a null body when expansion is disabled ??? + procedure Build_Discr_Checking_Funcs (N : Node_Id); -- Builds function which checks whether the component name is consistent -- with the current discriminants. N is the full type declaration node, diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 54b2f62cfe4..2e97516cd3e 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -92,6 +92,11 @@ package body Sem_Ch3 is -- abstract interface types implemented by a record type or a derived -- record type. + procedure Build_Access_Subprogram_Wrapper (Decl : Node_Id); + -- When an access_to_subprogram type has pre/postconditions, we + -- build a subprogram that includes these contracts and is invoked + -- by any indirect call through the corresponding access type. + procedure Build_Derived_Type (N : Node_Id; Parent_Type : Entity_Id; @@ -3136,6 +3141,17 @@ package body Sem_Ch3 is Validate_Access_Type_Declaration (T, N); + -- If the type has contracts, we create the corresponding + -- wrapper at once, before analyzing the aspect + -- specifications, so that pre/postconditions can be + -- handled directly on the generated wrapper. + + if Ada_Version >= Ada_2020 + and then Present (Aspect_Specifications (N)) + then + Build_Access_Subprogram_Wrapper (N); + end if; + when N_Access_To_Object_Definition => Access_Type_Declaration (T, Def); @@ -6447,6 +6463,146 @@ package body Sem_Ch3 is return Anon; end Replace_Anonymous_Access_To_Protected_Subprogram; + ------------------------------------- + -- Build_Access_Subprogram_Wrapper -- + ------------------------------------- + + procedure Build_Access_Subprogram_Wrapper (Decl : Node_Id) is + Loc : constant Source_Ptr := Sloc (Decl); + Id : constant Entity_Id := Defining_Identifier (Decl); + Type_Def : constant Node_Id := Type_Definition (Decl); + Specs : constant List_Id := + Parameter_Specifications (Type_Def); + Profile : constant List_Id := New_List; + Subp : constant Entity_Id := Make_Temporary (Loc, 'A'); + + Contracts : constant List_Id := New_List; + Form_P : Node_Id; + New_P : Node_Id; + New_Decl : Node_Id; + Spec : Node_Id; + + procedure Replace_Type_Name (Expr : Node_Id); + -- In the expressions for contract aspects, replace + -- occurrences of the access type with the name of the + -- subprogram entity, as needed, e.g. for 'Result. + -- Apects that are not contracts 9e.g. Size or Aligment) + -- remain on the originsl access type declaration. + -- What about expanded names denoting formals, whose prefix + -- in the source is the type name ??? + + ----------------------- + -- Replace_Type_Name -- + ----------------------- + + procedure Replace_Type_Name (Expr : Node_Id) is + function Process (N : Node_Id) return Traverse_Result; + function Process (N : Node_Id) return Traverse_Result is + begin + if Nkind (N) = N_Attribute_Reference + and then Is_Entity_Name (Prefix (N)) + and then Chars (Prefix (N)) = Chars (Id) + then + Set_Prefix (N, Make_Identifier (Sloc (N), Chars (Subp))); + end if; + + return OK; + end Process; + + procedure Traverse is new Traverse_Proc (Process); + begin + Traverse (Expr); + end Replace_Type_Name; + + begin + if Ekind_In (Id, E_Access_Subprogram_Type, + E_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Protected_Subprogram_Type, + E_Anonymous_Access_Subprogram_Type) + then + null; + + else + Error_Msg_N + ("illegal pre/postcondition on access type", Decl); + return; + end if; + + declare + Asp : Node_Id; + A_Id : Aspect_Id; + Cond : Node_Id; + Expr : Node_Id; + + begin + Asp := First (Aspect_Specifications (Decl)); + while Present (Asp) loop + A_Id := Get_Aspect_Id (Chars (Identifier (Asp))); + if A_Id = Aspect_Pre or else A_Id = Aspect_Post then + Cond := Asp; + Expr := Expression (Cond); + Replace_Type_Name (Expr); + Next (Asp); + + Remove (Cond); + Append (Cond, Contracts); + + else + Next (Asp); + end if; + end loop; + end; + + -- If there are no contract aspects, no need for a wrapper. + + if Is_Empty_List (Contracts) then + return; + end if; + + Form_P := First (Specs); + + while Present (Form_P) loop + New_P := New_Copy_Tree (Form_P); + Set_Defining_Identifier (New_P, + Make_Defining_Identifier + (Loc, Chars (Defining_Identifier (Form_P)))); + Append (New_P, Profile); + Next (Form_P); + end loop; + + -- Add to parameter specifications the access parameter that + -- is passed in from an indirect call. + + Append ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Make_Temporary (Loc, 'P'), + Parameter_Type => New_Occurrence_Of (Id, Loc)), + Profile); + + if Nkind (Type_Def) = N_Access_Procedure_Definition then + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Subp, + Parameter_Specifications => Profile); + else + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Subp, + Parameter_Specifications => Profile, + Result_Definition => + New_Copy_Tree + (Result_Definition (Type_Definition (Decl)))); + end if; + + New_Decl := + Make_Subprogram_Declaration (Loc, Specification => Spec); + Set_Aspect_Specifications (New_Decl, Contracts); + + Insert_After (Decl, New_Decl); + Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp); + Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl); + end Build_Access_Subprogram_Wrapper; + ------------------------------- -- Build_Derived_Access_Type -- ------------------------------- diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 410a65365c2..9e7f4c89d8c 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4533,185 +4533,6 @@ package body Sem_Prag is -- a class-wide precondition only if one of its ancestors has an -- explicit class-wide precondition. - procedure Build_Access_Subprogram_Wrapper - (Decl : Node_Id; - Prag : Node_Id); - -- When an access_to_subprogram type has pre/postconditions, we - -- build a subprogram that includes these contracts and is invoked - -- by any indirect call through the corresponding access type. - - procedure Build_Access_Subprogram_Wrapper_Body - (Decl : Node_Id; - New_Decl : Node_Id); - -- Build the wrapper body, which holds the indirect call through - -- an access_to_subprogram, and whose expansion incorporates the - -- contracts of the access type declaration. - - ------------------------------------- - -- Build_Access_Subprogram_Wrapper -- - ------------------------------------- - - procedure Build_Access_Subprogram_Wrapper - (Decl : Node_Id; - Prag : Node_Id) - is - Loc : constant Source_Ptr := Sloc (Decl); - Id : constant Entity_Id := Defining_Identifier (Decl); - Type_Def : constant Node_Id := Type_Definition (Decl); - Specs : constant List_Id := Parameter_Specifications (Type_Def); - Profile : constant List_Id := New_List; - - Form_P : Node_Id; - New_P : Node_Id; - New_Decl : Node_Id; - Spec : Node_Id; - Subp : Entity_Id; - - begin - if Ekind_In (Id, E_Access_Subprogram_Type, - E_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Protected_Subprogram_Type, - E_Anonymous_Access_Subprogram_Type) - then - null; - - else - Error_Msg_N - ("illegal pre/postcondition on access type", N); - return; - end if; - - Subp := Make_Temporary (Loc, 'A'); - Form_P := First (Specs); - - while Present (Form_P) loop - New_P := New_Copy_Tree (Form_P); - Set_Defining_Identifier (New_P, - Make_Defining_Identifier - (Loc, Chars (Defining_Identifier (Form_P)))); - Append (New_P, Profile); - Next (Form_P); - end loop; - - -- Add to parameter specifications the access parameter that - -- is passed from an indirect call. - - Append ( - Make_Parameter_Specification (Loc, - Defining_Identifier => Make_Temporary (Loc, 'P'), - Parameter_Type => New_Occurrence_Of (Id, Loc)), - Profile); - - if Nkind (Type_Def) = N_Access_Procedure_Definition then - Spec := - Make_Procedure_Specification (Loc, - Defining_Unit_Name => Subp, - Parameter_Specifications => Profile); - else - Spec := - Make_Function_Specification (Loc, - Defining_Unit_Name => Subp, - Parameter_Specifications => Profile, - Result_Definition => - New_Copy_Tree - (Result_Definition (Type_Definition (Decl)))); - end if; - - New_Decl := - Make_Subprogram_Declaration (Loc, Specification => Spec); - Set_Aspect_Specifications (New_Decl, - New_Copy_List_Tree (Aspect_Specifications (Decl))); - - declare - Asp : Node_Id; - - begin - Asp := First (Aspect_Specifications (New_Decl)); - while Present (Asp) loop - Set_Aspect_Rep_Item (Asp, Empty); - Set_Entity (Asp, Empty); - Set_Analyzed (Asp, False); - Next (Asp); - end loop; - end; - - Insert_After (Prag, New_Decl); - Set_Access_Subprogram_Wrapper (Designated_Type (Id), Subp); - Build_Access_Subprogram_Wrapper_Body (Decl, New_Decl); - end Build_Access_Subprogram_Wrapper; - - ------------------------------------------ - -- Build_Access_Subprogram_Wrapper_Body -- - ------------------------------------------ - - procedure Build_Access_Subprogram_Wrapper_Body - (Decl : Node_Id; - New_Decl : Node_Id) - is - Loc : constant Source_Ptr := Sloc (Decl); - Actuals : constant List_Id := New_List; - Type_Def : constant Node_Id := Type_Definition (Decl); - Type_Id : constant Entity_Id := Defining_Identifier (Decl); - Spec_Node : constant Node_Id := - New_Copy_Tree (Specification (New_Decl)); - - Act : Node_Id; - Body_Node : Node_Id; - Call_Stmt : Node_Id; - Ptr : Entity_Id; - begin - if not Expander_Active then - return; - end if; - - Set_Defining_Unit_Name (Spec_Node, - Make_Defining_Identifier - (Loc, Chars (Defining_Unit_Name (Spec_Node)))); - - -- Create List of actuals for indirect call. The last - -- parameter of the subprogram is the access value itself. - - Act := First (Parameter_Specifications (Spec_Node)); - - while Present (Act) loop - Append_To (Actuals, - Make_Identifier (Loc, Chars (Defining_Identifier (Act)))); - Next (Act); - exit when Act = Last (Parameter_Specifications (Spec_Node)); - end loop; - - Ptr := - Defining_Identifier - (Last (Parameter_Specifications (Spec_Node))); - - if Nkind (Type_Def) = N_Access_Procedure_Definition then - Call_Stmt := Make_Procedure_Call_Statement (Loc, - Name => - Make_Explicit_Dereference - (Loc, New_Occurrence_Of (Ptr, Loc)), - Parameter_Associations => Actuals); - else - Call_Stmt := Make_Simple_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => Make_Explicit_Dereference - (Loc, New_Occurrence_Of (Ptr, Loc)), - Parameter_Associations => Actuals)); - end if; - - Body_Node := Make_Subprogram_Body (Loc, - Specification => Spec_Node, - Declarations => New_List, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Call_Stmt))); - - -- Place body in list of freeze actions for the type. - - Ensure_Freeze_Node (Type_Id); - Append_Freeze_Actions (Type_Id, New_List (Body_Node)); - end Build_Access_Subprogram_Wrapper_Body; - ----------------------------- -- Inherits_Class_Wide_Pre -- ----------------------------- @@ -4953,17 +4774,11 @@ package body Sem_Prag is then null; - elsif Ada_Version >= Ada_2020 - and then Nkind (Subp_Decl) = N_Full_Type_Declaration - then - - -- Access_To_Subprogram type has pre/postconditions. - -- Build wrapper subprogram to carry the contract items. - - Build_Access_Subprogram_Wrapper (Subp_Decl, N); - return; + -- Access_To_Subprogram type can have pre/postconditions, but + -- these are trasnfered to the generated subprogram wrapper and + -- analyzed there. - -- Otherwise the placement is illegal + -- Otherwise the placement of the pragma is illegal else Pragma_Misplaced; -- 2.30.2