Patchwork [Ada] Handling of pragma Preelaborable_Initialization for generic types

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 22, 2010, 9:32 a.m.
Message ID <20101022093246.GA8151@adacore.com>
Download mbox | patch
Permalink /patch/68818/
State New
Headers show

Comments

Arnaud Charlet - Oct. 22, 2010, 9:32 a.m.
This change fixes two issues with the handling of pragma
Preelaborable_Initialization when applied to generic types.
The compiler erroneously rejected such a pragma when appplied to a generic
formal derived type, and erroneously accepted a misplaced pragma appearing
in the declarations of a generic package instead of the generic formal part.

The first compilation below must be accepted; the second must be rejected
with the indicated error message.

$ gcc -c preelab_formal_derived_type.ads
$ gcc -c pragma_pi_placement.ads
pragma_pi_placement.ads:4:41: pragma "Preelaborable_Initialization" argument must be in same declarative part

package Preelab_Formal_Derived_Type is
   pragma Preelaborate;
   type T is null record;
   generic
      type FDT is new T;
      pragma Preelaborable_Initialization (FDT);
   package Gen is
   end Gen;
end Preelab_Formal_Derived_Type;

generic
   type T is private;
package Pragma_PI_Placement is
   pragma Preelaborable_Initialization (T);
end Pragma_PI_Placement;

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

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.

Patch

Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 165807)
+++ sem_prag.adb	(working copy)
@@ -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;
 
Index: sem_ch12.adb
===================================================================
--- sem_ch12.adb	(revision 165803)
+++ sem_ch12.adb	(working copy)
@@ -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 --
    ---------------------
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 165808)
+++ sem_util.adb	(working copy)
@@ -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 --
    ------------
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 165808)
+++ sem_util.ads	(working copy)
@@ -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.