@@ -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;
@@ -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;
@@ -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 --
--------------------------------------
@@ -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
new file mode 100644
@@ -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;
new file mode 100644
@@ -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;
new file mode 100644
@@ -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" }
new file mode 100644
@@ -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);