diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index cfcf449ffb6..354b51a7846 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,37 @@ +2017-04-27 Ed Schonberg + + * sem_util.adb, sem_util.ads (Build_Class_Wide_Clone_Body): + Build body of subprogram that has a class-wide condition that + contains calls to other primitives. + (Build_Class_Wide_Clone_Call); Build a call to the common + class-wide clone of a subprogram with classwide conditions. The + body of the subprogram becomes a wrapper for a call to the + clone. The inherited operation becomes a similar wrapper to which + modified conditions apply, and the call to the clone includes + the proper conversion in a call the parent operation. + (Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id): For a + subprogram that has a classwide condition that contains calls to + other primitives, build an internal subprogram that is invoked + through a type-specific wrapper for all inherited subprograms + that may have a modified condition. + * sem_prag.adb (Check_References): If subprogram has a classwide + condition, create entity for corresponding clone, to be invoked + through wrapper subprograns. + (Analyze_Pre_Post_Condition_In_Decl_Part): Do not emit error + message about placement if pragma isi internally generated. + * sem_ch6.adb (Analyze_Subprogram_Body_Helper): If subprogram has + a classwide clone, build body of clone as copy of original body, + and rewrite original body as a wrapper as a wrapper for a call to + the clone, so that it incorporates the original pre/postconditions + of the subprogram. + * freeze.adb (Check_Inherited_Conditions): For an inherited + subprogram that inherits a classwide condition, build spec and + body of corresponding wrapper so that call to inherited operation + gets the modified conditions. + * contracts.adb (Analyze_Contracts): If analysis of classwide + condition has created a clone for a primitive operation, analyze + declaration of clone. + 2017-04-27 Steve Baird * exp_util.adb (Build_Allocate_Deallocate_Proc): diff --git a/gcc/ada/contracts.adb b/gcc/ada/contracts.adb index e4dc59ece28..ce61fdc14c0 100644 --- a/gcc/ada/contracts.adb +++ b/gcc/ada/contracts.adb @@ -384,9 +384,23 @@ package body Contracts is N_Generic_Subprogram_Declaration, N_Subprogram_Declaration) then - Analyze_Entry_Or_Subprogram_Contract - (Subp_Id => Defining_Entity (Decl), - Freeze_Id => Freeze_Id); + declare + Subp_Id : constant Entity_Id := Defining_Entity (Decl); + + begin + Analyze_Entry_Or_Subprogram_Contract (Subp_Id, Freeze_Id); + + -- If analysis of a classwide pre/postcondition indicates + -- that a class-wide clone is needed, analyze its declaration + -- now. Its body is created when the body of the original + -- operation is analyzed (and rewritten). + + if Is_Subprogram (Subp_Id) + and then Present (Class_Wide_Clone (Subp_Id)) + then + Analyze (Unit_Declaration_Node (Class_Wide_Clone (Subp_Id))); + end if; + end; -- Entry or subprogram bodies diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index 890a6a7c9d0..1c8f9e6fc48 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -55,7 +55,6 @@ with Sem_Ch6; use Sem_Ch6; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Ch13; use Sem_Ch13; -with Sem_Disp; use Sem_Disp; with Sem_Eval; use Sem_Eval; with Sem_Mech; use Sem_Mech; with Sem_Prag; use Sem_Prag; @@ -1408,7 +1407,6 @@ package body Freeze is New_Prag : Node_Id; Op_Node : Elmt_Id; Par_Prim : Entity_Id; - Par_Type : Entity_Id; Prim : Entity_Id; begin @@ -1459,7 +1457,6 @@ package body Freeze is if not Comes_From_Source (Prim) and then Present (Alias (Prim)) then Par_Prim := Alias (Prim); - Par_Type := Find_Dispatching_Type (Par_Prim); -- Analyze the contract items of the parent operation, before -- they are rewritten when inherited. @@ -1505,80 +1502,53 @@ package body Freeze is -- one, and whose inherited expression has been updated above. -- These expressions are the arguments of pragmas that are part -- of the declarations of the wrapper. The wrapper holds a single - -- statement that is a call to the parent primitive, where the + -- statement that is a call to the class-wide clone, where the -- controlling actuals are conversions to the corresponding type -- in the parent primitive: - -- procedure New_Prim (F1 : T1.; ...) is - -- pragma Check (Precondition, Expr); + -- procedure New_Prim (F1 : T1; ...); + -- procedure New_Prim (F1 : T1; ...) is + -- pragma Check (Precondition, Expr); -- begin - -- Par_Prim (Par_Type (F1) ..); + -- Par_Prim_Clone (Par_Type (F1), ...); -- end; - -- If the primitive is a function the statement is a call + -- If the primitive is a function the statement is a return + -- statement with a call. declare - Loc : constant Source_Ptr := Sloc (R); - Actuals : List_Id; - Call : Node_Id; - Formal : Entity_Id; - New_F_Spec : Node_Id; - New_Formal : Entity_Id; - New_Proc : Node_Id; - New_Spec : Node_Id; + Loc : constant Source_Ptr := Sloc (R); + Par_R : constant Node_Id := Parent (R); + New_Body : Node_Id; + New_Decl : Node_Id; + New_Spec : Node_Id; begin - Actuals := Empty_List; - New_Spec := Build_Overriding_Spec (Par_Prim, R); - Formal := First_Formal (Par_Prim); - New_F_Spec := First (Parameter_Specifications (New_Spec)); + New_Spec := Build_Overriding_Spec (Par_Prim, R); + New_Decl := + Make_Subprogram_Declaration (Loc, + Specification => New_Spec); - while Present (Formal) loop - New_Formal := Defining_Identifier (New_F_Spec); + -- Insert the declaration and the body of the wrapper after + -- type declaration that generates inherited operation. For + -- a null procedure, the declaration implies a null body. - -- If controlling argument, add conversion + if Nkind (New_Spec) = N_Procedure_Specification + and then Null_Present (New_Spec) + then + Insert_After_And_Analyze (Par_R, New_Decl); - if Etype (Formal) = Par_Type then - Append_To (Actuals, - Make_Type_Conversion (Loc, - New_Occurrence_Of (Par_Type, Loc), - New_Occurrence_Of (New_Formal, Loc))); - - else - Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); - end if; - - Next_Formal (Formal); - Next (New_F_Spec); - end loop; - - if Ekind (Par_Prim) = E_Procedure then - Call := - Make_Procedure_Call_Statement (Loc, - Name => - New_Occurrence_Of (Par_Prim, Loc), - Parameter_Associations => Actuals); else - Call := - Make_Simple_Return_Statement (Loc, - Expression => - Make_Function_Call (Loc, - Name => - New_Occurrence_Of (Par_Prim, Loc), - Parameter_Associations => Actuals)); + -- Build body as wrapper to a call to the already built + -- class-wide clone. + + New_Body := + Build_Class_Wide_Clone_Call + (Loc, Decls, Par_Prim, New_Spec); + + Insert_List_After_And_Analyze + (Par_R, New_List (New_Decl, New_Body)); end if; - - New_Proc := - Make_Subprogram_Body (Loc, - Specification => New_Spec, - Declarations => Decls, - Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc, - Statements => New_List (Call), - End_Label => Make_Identifier (Loc, Chars (Prim)))); - - Insert_After (Parent (R), New_Proc); - Analyze (New_Proc); end; Needs_Wrapper := False; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 49bcc9b6064..32384d9e619 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -415,7 +415,7 @@ package body Sem_Ch6 is Orig_N := Original_Node (N); Remove_Aspects (Orig_N); - -- Propagate any pragmas that apply to the expression function to the + -- Propagate any pragmas that apply to expression function to the -- proper body when the expression function acts as a completion. -- Aspects are automatically transfered because of node rewriting. @@ -3624,6 +3624,25 @@ package body Sem_Ch6 is end if; end if; + -- If the subprogram has a class-wide clone, build its body as a copy + -- of the original body, and rewrite body of original subprogram as a + -- wrapper that calls the clone. + + if Present (Spec_Id) + and then Present (Class_Wide_Clone (Spec_Id)) + and then (Comes_From_Source (N) or else Was_Expression_Function (N)) + then + Build_Class_Wide_Clone_Body (Spec_Id, N); + + -- This is the new body for the existing primitive operation + + Rewrite (N, Build_Class_Wide_Clone_Call + (Sloc (N), New_List, Spec_Id, Parent (Spec_Id))); + Set_Has_Completion (Spec_Id, False); + Analyze (N); + return; + end if; + -- Place subprogram on scope stack, and make formals visible. If there -- is a spec, the visible entity remains that of the spec. diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 10ec8d75d92..f9e710db778 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -4424,6 +4424,14 @@ package body Sem_Prag is end if; end; + -- A renaming declaration may inherit a generated pragma, its + -- placement comes from expansion, not from source. + + elsif Nkind (Subp_Decl) = N_Subprogram_Renaming_Declaration + and then not Comes_From_Source (N) + then + null; + -- Otherwise the placement is illegal else @@ -23949,6 +23957,9 @@ package body Sem_Prag is (N : Node_Id; Freeze_Id : Entity_Id := Empty) is + Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); + Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); + Disp_Typ : Entity_Id; -- The dispatching type of the subprogram subject to the pre- or -- postcondition. @@ -23995,6 +24006,18 @@ package body Sem_Prag is ("operation in class-wide condition must be primitive " & "of &", Nod, Disp_Typ); end if; + + -- Otherwise we have a call to an overridden primitive, and + -- we will create a common class-wide clone for the body of + -- original operation and its eventual inherited versions. + -- If the original operation dispatches on result it is + -- never inherited and there is no need for a clone. + + elsif not Is_Abstract_Subprogram (Spec_Id) + and then No (Class_Wide_Clone (Spec_Id)) + and then not Has_Controlling_Result (Spec_Id) + then + Build_Class_Wide_Clone_Decl (Spec_Id); end if; end; @@ -24027,10 +24050,7 @@ package body Sem_Prag is -- Local variables - Subp_Decl : constant Node_Id := Find_Related_Declaration_Or_Body (N); - Spec_Id : constant Entity_Id := Unique_Defining_Entity (Subp_Decl); - Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); - + Expr : constant Node_Id := Expression (Get_Argument (N, Spec_Id)); Saved_GM : constant Ghost_Mode_Type := Ghost_Mode; -- Save the Ghost mode to restore on exit @@ -24116,6 +24136,15 @@ package body Sem_Prag is End_Scope; end if; + -- If analysis of the condition indicates that a class-wide clone + -- has been created, build and analyze its declaration. + + if Is_Subprogram (Spec_Id) + and then Present (Class_Wide_Clone (Spec_Id)) + then + Analyze (Unit_Declaration_Node (Class_Wide_Clone (Spec_Id))); + end if; + -- Currently it is not possible to inline pre/postconditions on a -- subprogram subject to pragma Inline_Always. diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index f924b739b68..e158905b0f2 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -1164,6 +1164,141 @@ package body Sem_Util is return Empty; end Build_Actual_Subtype_Of_Component; + --------------------------------- + -- Build_Class_Wide_Clone_Body -- + --------------------------------- + + procedure Build_Class_Wide_Clone_Body + (Spec_Id : Entity_Id; + Bod : Node_Id) + is + Loc : constant Source_Ptr := Sloc (Bod); + Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); + Clone_Body : Node_Id; + + begin + -- The declaration of the class-wide clone was created when the + -- corresponding class-wide condition was analyzed. + + Clone_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Subprogram_Spec (Parent (Clone_Id)), + Declarations => Declarations (Bod), + Handled_Statement_Sequence => Handled_Statement_Sequence (Bod)); + + -- The new operation is internal and overriding indicators do not apply + -- (the original primitive may have carried one). + + Set_Must_Override (Specification (Clone_Body), False); + Insert_Before (Bod, Clone_Body); + Analyze (Clone_Body); + end Build_Class_Wide_Clone_Body; + + --------------------------------- + -- Build_Class_Wide_Clone_Call -- + --------------------------------- + + function Build_Class_Wide_Clone_Call + (Loc : Source_Ptr; + Decls : List_Id; + Spec_Id : Entity_Id; + Spec : Node_Id) return Node_Id + is + Clone_Id : constant Entity_Id := Class_Wide_Clone (Spec_Id); + Par_Type : constant Entity_Id := Find_Dispatching_Type (Spec_Id); + + Actuals : List_Id; + Call : Node_Id; + Formal : Entity_Id; + New_Body : Node_Id; + New_F_Spec : Entity_Id; + New_Formal : Entity_Id; + + begin + Actuals := Empty_List; + Formal := First_Formal (Spec_Id); + New_F_Spec := First (Parameter_Specifications (Spec)); + + -- Build parameter association for call to class-wide clone. + + while Present (Formal) loop + New_Formal := Defining_Identifier (New_F_Spec); + + -- If controlling argument and operation is inherited, add conversion + -- to parent type for the call. + + if Etype (Formal) = Par_Type + and then not Is_Empty_List (Decls) + then + Append_To (Actuals, + Make_Type_Conversion (Loc, + New_Occurrence_Of (Par_Type, Loc), + New_Occurrence_Of (New_Formal, Loc))); + + else + Append_To (Actuals, New_Occurrence_Of (New_Formal, Loc)); + end if; + + Next_Formal (Formal); + Next (New_F_Spec); + end loop; + + if Ekind (Spec_Id) = E_Procedure then + Call := + Make_Procedure_Call_Statement (Loc, + Name => New_Occurrence_Of (Clone_Id, Loc), + Parameter_Associations => Actuals); + else + Call := + Make_Simple_Return_Statement (Loc, + Expression => + Make_Function_Call (Loc, + Name => New_Occurrence_Of (Clone_Id, Loc), + Parameter_Associations => Actuals)); + end if; + + New_Body := + Make_Subprogram_Body (Loc, + Specification => + Copy_Subprogram_Spec (Spec), + Declarations => Decls, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, + Statements => New_List (Call), + End_Label => Make_Identifier (Loc, Chars (Spec_Id)))); + + return New_Body; + end Build_Class_Wide_Clone_Call; + + --------------------------------- + -- Build_Class_Wide_Clone_Decl -- + --------------------------------- + + procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Spec_Id); + Clone_Id : constant Entity_Id := + Make_Defining_Identifier (Loc, + New_External_Name (Chars (Spec_Id), Suffix => "CL")); + + Decl : Node_Id; + Spec : Node_Id; + + begin + Spec := Copy_Subprogram_Spec (Parent (Spec_Id)); + Set_Must_Override (Spec, False); + Set_Must_Not_Override (Spec, False); + Set_Defining_Unit_Name (Spec, Clone_Id); + + Decl := Make_Subprogram_Declaration (Loc, Spec); + Append (Decl, List_Containing (Unit_Declaration_Node (Spec_Id))); + + -- Link clone to original subprogram, for use when building body and + -- wrapper call to inherited operation. + + Set_Class_Wide_Clone (Spec_Id, Clone_Id); + end Build_Class_Wide_Clone_Decl; + ----------------------------- -- Build_Component_Subtype -- ----------------------------- @@ -5245,6 +5380,14 @@ package body Sem_Util is Result := New_Copy_Tree (Spec); + -- However, the spec of a null procedure carries the corresponding null + -- statement of the body (created by the parser), and this cannot be + -- shared with the new subprogram spec. + + if Nkind (Result) = N_Procedure_Specification then + Set_Null_Statement (Result, Empty); + end if; + -- Create a new entity for the defining unit name Def_Id := Defining_Unit_Name (Result); diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index de0e2a8a1a1..7463ceace83 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -209,6 +209,52 @@ package Sem_Util is -- Determine whether a selected component has a type that depends on -- discriminants, and build actual subtype for it if so. + -- Handling of inherited primitives whose ancestor have class-wide + -- pre/post conditions. + + -- If a primitive operation of a parent type has a class-wide pre/post + -- condition that includes calls to other primitives, and that operation + -- is inherited by a descendant type that also overrides some of these + -- other primitives, the condition that applies to the inherited + -- operation has a modified condition in which the overridden primitives + -- have been replaced by the primitives of the descendent type. A call + -- to the inherited operation cannot be simply a call to the parent + -- operation (with an appropriate conversion) as is the case for other + -- inherited operations, but must appear with a wrapper subprogram to which + -- the modified conditions apply. Furthermore the call to the parent + -- operation must not be subject to the original class-wide condition, + -- given that modified conditions apply. To implement these semantics + -- economically we create a subprogram body (a "class-wide clone") to + -- which no pre/postconditions apply, and we create bodies for the + -- original and the inherited operation that have their respective + -- pre/post conditions and simply call the clone. The following operations + -- take care of constructing declaration and body of the clone, and + -- building the calls to it within the appropriate wrappers. + + procedure Build_Class_Wide_Clone_Body + (Spec_Id : Entity_Id; + Bod : Node_Id); + -- Build body of subprogram that has a class-wide condition that contains + -- calls to other primitives. Spec_Id is the Id of the subprogram, and B + -- is its source body, which becomes the body of the clone. + + function Build_Class_Wide_Clone_Call + (Loc : Source_Ptr; + Decls : List_Id; + Spec_Id : Entity_Id; + Spec : Node_Id) return Node_Id; + -- Build a call to the common class-wide clone of a subprogram with + -- class-wide conditions. The body of the subprogram becomes a wrapper + -- for a call to the clone. The inherited operation becomes a similar + -- wrapper to which modified conditions apply, and the call to the + -- clone includes the proper conversion in a call the parent operation. + + procedure Build_Class_Wide_Clone_Decl (Spec_Id : Entity_Id); + -- For a subprogram that has a clas-wide condition that contains calls + -- to other primitives, build an internal subprogram that is invoked + -- through a type-specific wrapper for all inherited subprograms that + -- may have a modified condition. + function Build_Default_Subtype (T : Entity_Id; N : Node_Id) return Entity_Id;