+2018-05-22 Justin Squirek <squirek@adacore.com>
+
+ * 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.
+
2018-05-22 Hristian Kirtchev <kirtchev@adacore.com>
* sem_ch6.adb (Analyze_Subprogram_Declaration): Set the proper
-- 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
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.
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
(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 --
---------------------
-- 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:
-- 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;
E : Entity_Id;
E_Id : Node_Id;
Effective : Boolean := False;
+ Orig_Def : Entity_Id;
+ Same_Decl : Boolean := False;
begin
GNAT_Pragma;
("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);
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;
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 --
--------------------------------------
-- 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
+2018-05-22 Justin Squirek <squirek@adacore.com>
+
+ * gnat.dg/pure_function1.adb, gnat.dg/pure_function1.ads,
+ gnat.dg/pure_function2.adb, gnat.dg/pure_function2.ads: New testcases.
+
2018-05-22 Richard Sandiford <richard.sandiford@linaro.org>
PR middle-end/85862
--- /dev/null
+-- { 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
+package Pure_Function1 is
+ function F return Integer;
+ pragma Pure_Function (F);
+ pragma Pure_Function (F);
+ pragma Pure_Function (F);
+end;
--- /dev/null
+-- { 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
+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);
projects / gcc.git / commitdiff