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