diff options
Diffstat (limited to 'gcc')
| -rw-r--r-- | gcc/ada/exp_ch3.adb | 72 | ||||
| -rw-r--r-- | gcc/ada/exp_ch3.ads | 11 | ||||
| -rw-r--r-- | gcc/ada/sem_ch3.adb | 156 | ||||
| -rw-r--r-- | 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 b207a1f..6e1e625 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 3ac7c9b..12387cf 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 54b2f62..2e97516 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 410a653..9e7f4c8 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; |