2010-10-22 Thomas Quinot <quinot@adacore.com>

	* sem_prag.adb, sem_ch12.adb, sem_util.adb, sem_util.ads
	(Is_Generic_Formal): Move from body of Sem_Ch12 to Sem_Util.
	(Check_Arg_Is_Local_Name): Fix check in the case of a pragma appearing
	immediately after a library unit.
	(Analyze_Pragma, case Preelaborable_Initialization): Pragma may apply to
	a formal derived type.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165810 138bc75d-0d04-0410-961f-82ee72b054a4

5 files changed, 101 insertions, 37 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 0dd91b931d8..ffaef4e72ec 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2010-10-22  Thomas Quinot  <quinot@adacore.com>
+
+	* sem_prag.adb, sem_ch12.adb, sem_util.adb, sem_util.ads
+	(Is_Generic_Formal): Move from body of Sem_Ch12 to Sem_Util.
+	(Check_Arg_Is_Local_Name): Fix check in the case of a pragma appearing
+	immediately after a library unit.
+	(Analyze_Pragma, case Preelaborable_Initialization): Pragma may apply to
+	a formal derived type.
+
 2010-10-22  Geert Bosch  <bosch@adacore.com>
 
 	* gcc-interface/Make-lang.in: Remove ttypef.ads
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index f5b313a7aa5..e51c6c101ae 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -470,12 +470,6 @@ package body Sem_Ch12 is
    --  Used to determine whether its body should be elaborated to allow
    --  front-end inlining.
 
-   function Is_Generic_Formal (E : Entity_Id) return Boolean;
-   --  Utility to determine whether a given entity is declared by means of
-   --  of a formal parameter declaration. Used to set properly the visibility
-   --  of generic formals of a generic package declared with a box or with
-   --  partial parametrization.
-
    procedure Set_Instance_Env
      (Gen_Unit : Entity_Id;
       Act_Unit : Entity_Id);
@@ -10480,29 +10474,6 @@ package body Sem_Ch12 is
       return Decl_Nodes;
    end Instantiate_Type;
 
-   -----------------------
-   -- Is_Generic_Formal --
-   -----------------------
-
-   function Is_Generic_Formal (E : Entity_Id) return Boolean is
-      Kind : Node_Kind;
-   begin
-      if No (E) then
-         return False;
-      else
-         Kind := Nkind (Parent (E));
-         return
-           Nkind_In (Kind, N_Formal_Object_Declaration,
-                           N_Formal_Package_Declaration,
-                           N_Formal_Type_Declaration)
-             or else
-               (Is_Formal_Subprogram (E)
-                 and then
-                   Nkind (Parent (Parent (E))) in
-                     N_Formal_Subprogram_Declaration);
-      end if;
-   end Is_Generic_Formal;
-
    ---------------------
    -- Is_In_Main_Unit --
    ---------------------
diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb
index 78bebfc7e92..552f4b1a30b 100644
--- a/gcc/ada/sem_prag.adb
+++ b/gcc/ada/sem_prag.adb
@@ -901,11 +901,67 @@ package body Sem_Prag is
             Error_Pragma_Arg ("argument for pragma% must be local name", Argx);
          end if;
 
-         if Is_Entity_Name (Argx)
-           and then Scope (Entity (Argx)) /= Current_Scope
-         then
-            Error_Pragma_Arg
-              ("pragma% argument must be in same declarative part", Arg);
+         --  No further check required if not an entity name
+
+         if not Is_Entity_Name (Argx) then
+            null;
+
+         else
+            declare
+               OK   : Boolean;
+               Ent  : constant Entity_Id := Entity (Argx);
+               Scop : constant Entity_Id := Scope (Ent);
+            begin
+               --  Case of a pragma applied to a compilation unit: pragma must
+               --  occur immediately after the program unit in the compilation.
+
+               if Is_Compilation_Unit (Ent) then
+                  declare
+                     Decl : constant Node_Id := Unit_Declaration_Node (Ent);
+                  begin
+                     --  Case of pragma placed immediately after spec
+
+                     if Parent (N) = Aux_Decls_Node (Parent (Decl)) then
+                        OK := True;
+
+                     --  Case of pragma placed immediately after body
+
+                     elsif Nkind (Decl) = N_Subprogram_Declaration
+                             and then Present (Corresponding_Body (Decl))
+                     then
+                        OK := Parent (N) =
+                                Aux_Decls_Node
+                                  (Parent (Unit_Declaration_Node
+                                             (Corresponding_Body (Decl))));
+
+                     --  All other cases are illegal
+
+                     else
+                        OK := False;
+                     end if;
+                  end;
+
+               --  Special restricted placement rule from 10.2.1(11.8/2)
+
+               elsif Is_Generic_Formal (Ent)
+                       and then Prag_Id = Pragma_Preelaborable_Initialization
+               then
+                  OK := List_Containing (N) =
+                          Generic_Formal_Declarations
+                            (Unit_Declaration_Node (Scop));
+
+               --  Default case, just check that the pragma occurs in the scope
+               --  of the entity denoted by the name.
+
+               else
+                  OK := Current_Scope = Scop;
+               end if;
+
+               if not OK then
+                  Error_Pragma_Arg
+                    ("pragma% argument must be in same declarative part", Arg);
+               end if;
+            end;
          end if;
       end Check_Arg_Is_Local_Name;
 
@@ -10985,11 +11041,15 @@ package body Sem_Prag is
             Check_First_Subtype (Arg1);
             Ent := Entity (Get_Pragma_Arg (Arg1));
 
-            if not Is_Private_Type (Ent)
-              and then not Is_Protected_Type (Ent)
+            if not (Is_Private_Type (Ent)
+                      or else
+                    Is_Protected_Type (Ent)
+                      or else
+                    (Is_Generic_Type (Ent) and then Is_Derived_Type (Ent)))
             then
                Error_Pragma_Arg
-                 ("pragma % can only be applied to private or protected type",
+                 ("pragma % can only be applied to private, formal derived or "
+                  & "protected type",
                   Arg1);
             end if;
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 109ee580976..d53e483dfc3 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -6559,6 +6559,25 @@ package body Sem_Util is
       end if;
    end Is_Fully_Initialized_Variant;
 
+   -----------------------
+   -- Is_Generic_Formal --
+   -----------------------
+
+   function Is_Generic_Formal (E : Entity_Id) return Boolean is
+      Kind : Node_Kind;
+   begin
+      if No (E) then
+         return False;
+      else
+         Kind := Nkind (Parent (E));
+         return
+           Nkind_In (Kind, N_Formal_Object_Declaration,
+                           N_Formal_Package_Declaration,
+                           N_Formal_Type_Declaration)
+             or else Is_Formal_Subprogram (E);
+      end if;
+   end Is_Generic_Formal;
+
    ------------
    -- Is_LHS --
    ------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index be4987b9494..94786a1849b 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -733,6 +733,11 @@ package Sem_Util is
    --  means that the result returned is not crucial, but should err on the
    --  side of thinking things are fully initialized if it does not know.
 
+   function Is_Generic_Formal (E : Entity_Id) return Boolean;
+   --  Determine whether E is a generic formal parameter. In particular this is
+   --  used to set the visibility of generic formals of a generic package
+   --  declared with a box or with partial parametrization.
+
    function Is_Inherited_Operation (E : Entity_Id) return Boolean;
    --  E is a subprogram. Return True is E is an implicit operation inherited
    --  by a derived type declarations.