[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  <kirtchev@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.

From-SVN: r263097

gcc/ada/ChangeLog

+2018-07-31  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* 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  <dismukes@adacore.com>
 
 	* exp_ch6.adb (Expand_N_Extended_Return_Statement): Replace

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

@@ -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.
 

gcc/testsuite/ChangeLog

+2018-07-31  Hristian Kirtchev  <kirtchev@adacore.com>
+
+	* gnat.dg/global.adb, gnat.dg/global.ads: New testcase.
+
 2018-07-31  Gary Dismukes  <dismukes@adacore.com>
 
 	* gnat.dg/block_ext_return_assert_failure.adb: New testcase.

gcc/testsuite/gnat.dg/global.adb

+--  { 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;

gcc/testsuite/gnat.dg/global.ads

+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;