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.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-07-31 Hristian Kirtchev <kirtc...@adacore.com>
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.--- gcc/ada/exp_ch9.adb
+++ 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;
--- gcc/ada/sem_prag.adb
+++ 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.
--- /dev/null
new file mode 100644
+++ 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;
--- /dev/null
new file mode 100644
+++ 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;
