From 007443a0c1bb11ae55a43d562f070aba88a607c6 Mon Sep 17 00:00:00 2001 From: Hristian Kirtchev Date: Tue, 31 Jul 2018 09:55:59 +0000 Subject: [PATCH] [Ada] Spurious error on the placement of aspect Global This patch modifies the expansion of stand-alone subprogram bodies that appear in the body of a protected type to properly associate aspects and pragmas to the newly created spec for the subprogram body. As a result, the annotations are properly associated with the initial declaration of the subprogram. 2018-07-31 Hristian Kirtchev gcc/ada/ * exp_ch9.adb (Analyze_Pragmas): New routine. (Build_Private_Protected_Declaration): Code clean up. Relocate relevant aspects and pragmas from the stand-alone body to the newly created spec. Explicitly analyze any pragmas that have been either relocated or produced by the analysis of the aspects. (Move_Pragmas): New routine. * sem_prag.adb (Find_Related_Declaration_Or_Body): Recognize the case where a pragma applies to the internally created spec for a stand-along subprogram body declared in a protected body. gcc/testsuite/ * gnat.dg/global.adb, gnat.dg/global.ads: New testcase. From-SVN: r263097 --- gcc/ada/ChangeLog | 13 +++ gcc/ada/exp_ch9.adb | 151 ++++++++++++++++++++++++++----- gcc/ada/sem_prag.adb | 10 ++ gcc/testsuite/ChangeLog | 4 + gcc/testsuite/gnat.dg/global.adb | 87 ++++++++++++++++++ gcc/testsuite/gnat.dg/global.ads | 19 ++++ 6 files changed, 259 insertions(+), 25 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/global.adb create mode 100644 gcc/testsuite/gnat.dg/global.ads diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index f8da47c8fde..08fdfcebfca 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,16 @@ +2018-07-31 Hristian Kirtchev + + * exp_ch9.adb (Analyze_Pragmas): New routine. + (Build_Private_Protected_Declaration): Code clean up. Relocate + relevant aspects and pragmas from the stand-alone body to the + newly created spec. Explicitly analyze any pragmas that have + been either relocated or produced by the analysis of the + aspects. + (Move_Pragmas): New routine. + * sem_prag.adb (Find_Related_Declaration_Or_Body): Recognize the + case where a pragma applies to the internally created spec for a + stand-along subprogram body declared in a protected body. + 2018-07-31 Gary Dismukes * exp_ch6.adb (Expand_N_Extended_Return_Statement): Replace diff --git a/gcc/ada/exp_ch9.adb b/gcc/ada/exp_ch9.adb index 6266c613920..e7561df0fd2 100644 --- a/gcc/ada/exp_ch9.adb +++ b/gcc/ada/exp_ch9.adb @@ -23,6 +23,7 @@ -- -- ------------------------------------------------------------------------------ +with Aspects; use Aspects; with Atree; use Atree; with Einfo; use Einfo; with Elists; use Elists; @@ -53,6 +54,7 @@ with Sem_Ch9; use Sem_Ch9; with Sem_Ch11; use Sem_Ch11; with Sem_Elab; use Sem_Elab; with Sem_Eval; use Sem_Eval; +with Sem_Prag; use Sem_Prag; with Sem_Res; use Sem_Res; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; @@ -290,7 +292,7 @@ package body Exp_Ch9 is (N : Node_Id; Pid : Node_Id) return Node_Id; -- This routine constructs the unprotected version of a protected - -- subprogram body, which is contains all of the code in the original, + -- subprogram body, which contains all of the code in the original, -- unexpanded body. This is the version of the protected subprogram that is -- called from all protected operations on the same object, including the -- protected version of the same subprogram. @@ -3483,14 +3485,95 @@ package body Exp_Ch9 is function Build_Private_Protected_Declaration (N : Node_Id) return Entity_Id is + procedure Analyze_Pragmas (From : Node_Id); + -- Analyze all pragmas which follow arbitrary node From + + procedure Move_Pragmas (From : Node_Id; To : Node_Id); + -- Find all suitable source pragmas at the top of subprogram body From's + -- declarations and insert them after arbitrary node To. + + --------------------- + -- Analyze_Pragmas -- + --------------------- + + procedure Analyze_Pragmas (From : Node_Id) is + Decl : Node_Id; + + begin + Decl := Next (From); + while Present (Decl) loop + if Nkind (Decl) = N_Pragma then + Analyze_Pragma (Decl); + + -- No candidate pragmas are available for analysis + + else + exit; + end if; + + Next (Decl); + end loop; + end Analyze_Pragmas; + + ------------------ + -- Move_Pragmas -- + ------------------ + + procedure Move_Pragmas (From : Node_Id; To : Node_Id) is + Decl : Node_Id; + Insert_Nod : Node_Id; + Next_Decl : Node_Id; + + begin + pragma Assert (Nkind (From) = N_Subprogram_Body); + + -- The pragmas are moved in an order-preserving fashion + + Insert_Nod := To; + + -- Inspect the declarations of the subprogram body and relocate all + -- candidate pragmas. + + Decl := First (Declarations (From)); + while Present (Decl) loop + + -- Preserve the following declaration for iteration purposes, due + -- to possible relocation of a pragma. + + Next_Decl := Next (Decl); + + if Nkind (Decl) = N_Pragma then + Remove (Decl); + Insert_After (Insert_Nod, Decl); + Insert_Nod := Decl; + + -- Skip internally generated code + + elsif not Comes_From_Source (Decl) then + null; + + -- No candidate pragmas are available for relocation + + else + exit; + end if; + + Decl := Next_Decl; + end loop; + end Move_Pragmas; + + -- Local variables + + Body_Id : constant Entity_Id := Defining_Entity (N); Loc : constant Source_Ptr := Sloc (N); - Body_Id : constant Entity_Id := Defining_Entity (N); Decl : Node_Id; - Plist : List_Id; Formal : Entity_Id; - New_Spec : Node_Id; + Formals : List_Id; + Spec : Node_Id; Spec_Id : Entity_Id; + -- Start of processing for Build_Private_Protected_Declaration + begin Formal := First_Formal (Body_Id); @@ -3499,43 +3582,61 @@ package body Exp_Ch9 is -- expansion is enabled. if Present (Formal) or else Expander_Active then - Plist := Copy_Parameter_List (Body_Id); + Formals := Copy_Parameter_List (Body_Id); else - Plist := No_List; + Formals := No_List; end if; + Spec_Id := + Make_Defining_Identifier (Sloc (Body_Id), + Chars => Chars (Body_Id)); + + -- Indicate that the entity comes from source, to ensure that cross- + -- reference information is properly generated. The body itself is + -- rewritten during expansion, and the body entity will not appear in + -- calls to the operation. + + Set_Comes_From_Source (Spec_Id, True); + if Nkind (Specification (N)) = N_Procedure_Specification then - New_Spec := + Spec := Make_Procedure_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Sloc (Body_Id), - Chars => Chars (Body_Id)), - Parameter_Specifications => - Plist); + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Formals); else - New_Spec := + Spec := Make_Function_Specification (Loc, - Defining_Unit_Name => - Make_Defining_Identifier (Sloc (Body_Id), - Chars => Chars (Body_Id)), - Parameter_Specifications => Plist, + Defining_Unit_Name => Spec_Id, + Parameter_Specifications => Formals, Result_Definition => New_Occurrence_Of (Etype (Body_Id), Loc)); end if; - Decl := Make_Subprogram_Declaration (Loc, Specification => New_Spec); + Decl := Make_Subprogram_Declaration (Loc, Specification => Spec); + Set_Corresponding_Body (Decl, Body_Id); + Set_Corresponding_Spec (N, Spec_Id); + Insert_Before (N, Decl); - Spec_Id := Defining_Unit_Name (New_Spec); - -- Indicate that the entity comes from source, to ensure that cross- - -- reference information is properly generated. The body itself is - -- rewritten during expansion, and the body entity will not appear in - -- calls to the operation. + -- Associate all aspects and pragmas of the body with the spec. This + -- ensures that these annotations apply to the initial declaration of + -- the subprogram body. + + Move_Aspects (From => N, To => Decl); + Move_Pragmas (From => N, To => Decl); - Set_Comes_From_Source (Spec_Id, True); Analyze (Decl); + + -- The analysis of the spec may generate pragmas which require manual + -- analysis. Since the generation of the spec and the relocation of the + -- annotations is driven by the expansion of the stand-alone body, the + -- pragmas will not be analyzed in a timely manner. Do this now. + + Analyze_Pragmas (Decl); + + Set_Convention (Spec_Id, Convention_Protected); Set_Has_Completion (Spec_Id); - Set_Convention (Spec_Id, Convention_Protected); + return Spec_Id; end Build_Private_Protected_Declaration; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index babae30bd60..f1f463c23da 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -29643,6 +29643,16 @@ package body Sem_Prag is if Nkind (Original_Node (Stmt)) = N_Expression_Function then return Stmt; + -- The subprogram declaration is an internally generated spec + -- for a stand-alone subrogram body declared inside a protected + -- body. + + elsif Present (Corresponding_Body (Stmt)) + and then Comes_From_Source (Corresponding_Body (Stmt)) + and then Is_Protected_Type (Current_Scope) + then + return Stmt; + -- The subprogram is actually an instance housed within an -- anonymous wrapper package. diff --git a/gcc/testsuite/ChangeLog b/gcc/testsuite/ChangeLog index 2258aa25a0f..00cf622343e 100644 --- a/gcc/testsuite/ChangeLog +++ b/gcc/testsuite/ChangeLog @@ -1,3 +1,7 @@ +2018-07-31 Hristian Kirtchev + + * gnat.dg/global.adb, gnat.dg/global.ads: New testcase. + 2018-07-31 Gary Dismukes * gnat.dg/block_ext_return_assert_failure.adb: New testcase. diff --git a/gcc/testsuite/gnat.dg/global.adb b/gcc/testsuite/gnat.dg/global.adb new file mode 100644 index 00000000000..521a6293d75 --- /dev/null +++ b/gcc/testsuite/gnat.dg/global.adb @@ -0,0 +1,87 @@ +-- { dg-do compile } + +package body Global + with Refined_State => (State => Constit) +is + Constit : Integer := 123; + + protected body Prot_Typ is + procedure Force_Body is null; + + procedure Aspect_On_Spec + with Global => (Input => Constit); + procedure Aspect_On_Spec is null; + + procedure Aspect_On_Body + with Global => (Input => Constit) + is begin null; end Aspect_On_Body; + + procedure Pragma_On_Spec; + pragma Global ((Input => Constit)); + procedure Pragma_On_Spec is null; + + procedure Pragma_On_Body is + pragma Global ((Input => Constit)); + begin null; end Pragma_On_Body; + end Prot_Typ; + + protected body Prot_Obj is + procedure Force_Body is null; + + procedure Aspect_On_Spec + with Global => (Input => Constit); + procedure Aspect_On_Spec is null; + + procedure Aspect_On_Body + with Global => (Input => Constit) + is begin null; end Aspect_On_Body; + + procedure Pragma_On_Spec; + pragma Global ((Input => Constit)); + procedure Pragma_On_Spec is null; + + procedure Pragma_On_Body is + pragma Global ((Input => Constit)); + begin null; end Pragma_On_Body; + end Prot_Obj; + + task body Task_Typ is + procedure Aspect_On_Spec + with Global => (Input => Constit); + procedure Aspect_On_Spec is null; + + procedure Aspect_On_Body + with Global => (Input => Constit) + is begin null; end Aspect_On_Body; + + procedure Pragma_On_Spec; + pragma Global ((Input => Constit)); + procedure Pragma_On_Spec is null; + + procedure Pragma_On_Body is + pragma Global ((Input => Constit)); + begin null; end Pragma_On_Body; + begin + accept Force_Body; + end Task_Typ; + + task body Task_Obj is + procedure Aspect_On_Spec + with Global => (Input => Constit); + procedure Aspect_On_Spec is null; + + procedure Aspect_On_Body + with Global => (Input => Constit) + is begin null; end Aspect_On_Body; + + procedure Pragma_On_Spec; + pragma Global ((Input => Constit)); + procedure Pragma_On_Spec is null; + + procedure Pragma_On_Body is + pragma Global ((Input => Constit)); + begin null; end Pragma_On_Body; + begin + accept Force_Body; + end Task_Obj; +end Global; diff --git a/gcc/testsuite/gnat.dg/global.ads b/gcc/testsuite/gnat.dg/global.ads new file mode 100644 index 00000000000..0ff9b96b091 --- /dev/null +++ b/gcc/testsuite/gnat.dg/global.ads @@ -0,0 +1,19 @@ +package Global + with Abstract_State => (State with External) +is + protected type Prot_Typ is + procedure Force_Body; + end Prot_Typ; + + protected Prot_Obj is + procedure Force_Body; + end Prot_Obj; + + task type Task_Typ is + entry Force_Body; + end Task_Typ; + + task Task_Obj is + entry Force_Body; + end Task_Obj; +end Global; -- 2.30.2