[Ada] No error on misplaced pragma Pure_Function

[Pierre-Marie de Rodat <derodat at adacore dot com>]

This patch fixes an issue whereby placement of the pragma/aspect Pure_Function
was not verified to have been in the same declarative part as the function
declaration incorrectly allowing it to appear after a function body or in a
different region like a private section.

Tested on x86_64-pc-linux-gnu, committed on trunk

2018-05-22  Justin Squirek  <squirek@adacore.com>

gcc/ada/

	* sem_ch12.adb (In_Same_Declarative_Part): Moved to sem_util.
	(Freeze_Subprogram_Body, Install_Body): Modify calls to
	In_Same_Declarative_Part.
	* sem_prag.adb (Analyze_Pragma-Pragma_Pure_Function): Add check to
	verify pragma declaration is within the same declarative list with
	corresponding error message.
	* sem_util.adb, sem_util.ads (In_Same_Declarative_Part): Moved from
	sem_ch12.adb and generalized to be useful outside the scope of
	freezing.

gcc/testsuite/

	* gnat.dg/pure_function1.adb, gnat.dg/pure_function1.ads,
	gnat.dg/pure_function2.adb, gnat.dg/pure_function2.ads: New testcases.

--- gcc/ada/sem_ch12.adb
+++ gcc/ada/sem_ch12.adb
@@ -657,17 +657,6 @@ package body Sem_Ch12 is
    --  not done for the instantiation of the bodies, which only require the
    --  instances of the generic parents to be in scope.
 
-   function In_Same_Declarative_Part
-     (F_Node : Node_Id;
-      Inst   : Node_Id) return Boolean;
-   --  True if the instantiation Inst and the given freeze_node F_Node appear
-   --  within the same declarative part, ignoring subunits, but with no inter-
-   --  vening subprograms or concurrent units. Used to find the proper plave
-   --  for the freeze node of an instance, when the generic is declared in a
-   --  previous instance. If predicate is true, the freeze node of the instance
-   --  can be placed after the freeze node of the previous instance, Otherwise
-   --  it has to be placed at the end of the current declarative part.
-
    function In_Main_Context (E : Entity_Id) return Boolean;
    --  Check whether an instantiation is in the context of the main unit.
    --  Used to determine whether its body should be elaborated to allow
@@ -8664,7 +8653,8 @@ package body Sem_Ch12 is
 
       if Is_Generic_Instance (Par)
         and then Present (Freeze_Node (Par))
-        and then In_Same_Declarative_Part (Freeze_Node (Par), Inst_Node)
+        and then In_Same_Declarative_Part
+                   (Parent (Freeze_Node (Par)), Inst_Node)
       then
          --  The parent was a premature instantiation. Insert freeze node at
          --  the end the current declarative part.
@@ -8711,11 +8701,11 @@ package body Sem_Ch12 is
         and then Present (Freeze_Node (Par))
         and then Present (Enc_I)
       then
-         if In_Same_Declarative_Part (Freeze_Node (Par), Enc_I)
+         if In_Same_Declarative_Part (Parent (Freeze_Node (Par)), Enc_I)
            or else
              (Nkind (Enc_I) = N_Package_Body
-               and then
-                 In_Same_Declarative_Part (Freeze_Node (Par), Parent (Enc_I)))
+               and then In_Same_Declarative_Part
+                          (Parent (Freeze_Node (Par)), Parent (Enc_I)))
          then
             --  The enclosing package may contain several instances. Rather
             --  than computing the earliest point at which to insert its freeze
@@ -8985,46 +8975,6 @@ package body Sem_Ch12 is
         (Current_Scope, Current_Scope, Assoc_Null);
    end Init_Env;
 
-   ------------------------------
-   -- In_Same_Declarative_Part --
-   ------------------------------
-
-   function In_Same_Declarative_Part
-     (F_Node : Node_Id;
-      Inst   : Node_Id) return Boolean
-   is
-      Decls : constant Node_Id := Parent (F_Node);
-      Nod   : Node_Id;
-
-   begin
-      Nod := Parent (Inst);
-      while Present (Nod) loop
-         if Nod = Decls then
-            return True;
-
-         elsif Nkind_In (Nod, N_Subprogram_Body,
-                              N_Package_Body,
-                              N_Package_Declaration,
-                              N_Task_Body,
-                              N_Protected_Body,
-                              N_Block_Statement)
-         then
-            return False;
-
-         elsif Nkind (Nod) = N_Subunit then
-            Nod := Corresponding_Stub (Nod);
-
-         elsif Nkind (Nod) = N_Compilation_Unit then
-            return False;
-
-         else
-            Nod := Parent (Nod);
-         end if;
-      end loop;
-
-      return False;
-   end In_Same_Declarative_Part;
-
    ---------------------
    -- In_Main_Context --
    ---------------------
@@ -9536,7 +9486,7 @@ package body Sem_Ch12 is
             --  Freeze instance of inner generic after instance of enclosing
             --  generic.
 
-            if In_Same_Declarative_Part (Freeze_Node (Par), N) then
+            if In_Same_Declarative_Part (Parent (Freeze_Node (Par)), N) then
 
                --  Handle the following case:
 
@@ -9570,7 +9520,8 @@ package body Sem_Ch12 is
             --  instance of enclosing generic.
 
             elsif Nkind_In (Parent (N), N_Package_Body, N_Subprogram_Body)
-              and then In_Same_Declarative_Part (Freeze_Node (Par), Parent (N))
+              and then In_Same_Declarative_Part
+                         (Parent (Freeze_Node (Par)), Parent (N))
             then
                declare
                   Enclosing :  Entity_Id;

--- gcc/ada/sem_prag.adb
+++ gcc/ada/sem_prag.adb
@@ -21043,6 +21043,8 @@ package body Sem_Prag is
             E         : Entity_Id;
             E_Id      : Node_Id;
             Effective : Boolean := False;
+            Orig_Def  : Entity_Id;
+            Same_Decl : Boolean := False;
 
          begin
             GNAT_Pragma;
@@ -21076,11 +21078,27 @@ package body Sem_Prag is
                        ("pragma% requires a function name", Arg1);
                   end if;
 
-                  Set_Is_Pure (Def_Id);
+                  --  When we have a generic function we must jump up a level
+                  --  to the declaration of the wrapper package itself.
 
-                  if not Has_Pragma_Pure_Function (Def_Id) then
-                     Set_Has_Pragma_Pure_Function (Def_Id);
-                     Effective := True;
+                  Orig_Def := Def_Id;
+
+                  if Is_Generic_Instance (Def_Id) then
+                     while Nkind (Orig_Def) /= N_Package_Declaration loop
+                        Orig_Def := Parent (Orig_Def);
+                     end loop;
+                  end if;
+
+                  if In_Same_Declarative_Part (Parent (N), Orig_Def) then
+
+                     Same_Decl := True;
+
+                     Set_Is_Pure (Def_Id);
+
+                     if not Has_Pragma_Pure_Function (Def_Id) then
+                        Set_Has_Pragma_Pure_Function (Def_Id);
+                        Effective := True;
+                     end if;
                   end if;
 
                   exit when From_Aspect_Specification (N);
@@ -21094,6 +21112,10 @@ package body Sem_Prag is
                   Error_Msg_NE
                     ("pragma Pure_Function on& is redundant?r?",
                      N, Entity (E_Id));
+               elsif not Same_Decl then
+                  Error_Pragma_Arg
+                    ("pragma% argument must be in same declarative "
+                     & "part", Arg1);
                end if;
             end if;
          end Pure_Function;

--- gcc/ada/sem_util.adb
+++ gcc/ada/sem_util.adb
@@ -12024,6 +12024,50 @@ package body Sem_Util is
         and then Reverse_Storage_Order (Btyp);
    end In_Reverse_Storage_Order_Object;
 
+   ------------------------------
+   -- In_Same_Declarative_Part --
+   ------------------------------
+
+   function In_Same_Declarative_Part
+     (Context : Node_Id;
+      N       : Node_Id) return Boolean
+   is
+      Cont : Node_Id := Context;
+      Nod  : Node_Id;
+
+   begin
+      if Nkind (Cont) = N_Compilation_Unit_Aux then
+         Cont := Parent (Cont);
+      end if;
+
+      Nod := Parent (N);
+      while Present (Nod) loop
+         if Nod = Cont then
+            return True;
+
+         elsif Nkind_In (Nod, N_Accept_Statement,
+                              N_Block_Statement,
+                              N_Compilation_Unit,
+                              N_Entry_Body,
+                              N_Package_Body,
+                              N_Package_Declaration,
+                              N_Protected_Body,
+                              N_Subprogram_Body,
+                              N_Task_Body)
+         then
+            return False;
+
+         elsif Nkind (Nod) = N_Subunit then
+            Nod := Corresponding_Stub (Nod);
+
+         else
+            Nod := Parent (Nod);
+         end if;
+      end loop;
+
+      return False;
+   end In_Same_Declarative_Part;
+
    --------------------------------------
    -- In_Subprogram_Or_Concurrent_Unit --
    --------------------------------------

--- gcc/ada/sem_util.ads
+++ gcc/ada/sem_util.ads
@@ -1399,6 +1399,12 @@ package Sem_Util is
    --  Returns True if N denotes a component or subcomponent in a record or
    --  array that has Reverse_Storage_Order.
 
+   function In_Same_Declarative_Part
+     (Context : Node_Id;
+      N       : Node_Id) return Boolean;
+   --  True if the node N appears within the same declarative part denoted by
+   --  the node Context.
+
    function In_Subprogram_Or_Concurrent_Unit return Boolean;
    --  Determines if the current scope is within a subprogram compilation unit
    --  (inside a subprogram declaration, subprogram body, or generic subprogram

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/pure_function1.adb
@@ -0,0 +1,8 @@
+--  { dg-do compile }
+
+package body Pure_Function1 is
+   function F return Integer is (0);
+   pragma Pure_Function (F);  --  { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" }
+   pragma Pure_Function (F);  --  { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" }
+   pragma Pure_Function (F);  --  { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" }
+end;

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/pure_function1.ads
@@ -0,0 +1,6 @@
+package Pure_Function1 is
+   function F return Integer;
+   pragma Pure_Function (F);
+   pragma Pure_Function (F);
+   pragma Pure_Function (F);
+end;

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/pure_function2.adb
@@ -0,0 +1,10 @@
+--  { dg-do compile }
+
+function Pure_Function2 (X : Integer) return Integer is
+begin
+   return X;
+end Pure_Function2;
+
+pragma Pure_Function (Pure_Function2);  --  { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" }
+pragma Pure_Function (Pure_Function2);  --  { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" }
+pragma Pure_Function (Pure_Function2);  --  { dg-error "pragma \"Pure_Function\" argument must be in same declarative part" }

--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/pure_function2.ads
@@ -0,0 +1,5 @@
+function Pure_Function2 (X : Integer) return Integer with Pure_Function;
+
+pragma Pure_Function (Pure_Function2);
+pragma Pure_Function (Pure_Function2);
+pragma Pure_Function (Pure_Function2);