-- Start of processing for Activate_Elaborate_All_Desirable
begin
+ -- Do not set binder indication if expansion is disabled, as when
+ -- compiling a generic unit.
+
+ if not Expander_Active then
+ return;
+ end if;
+
Itm := First (CI);
while Present (Itm) loop
if Nkind (Itm) = N_With_Clause then
Write_Eol;
end if;
- -- Climb up the tree to make sure we are not inside a
- -- default expression of a parameter specification or
- -- a record component, since in both these cases, we
- -- will be doing the actual call later, not now, and it
- -- is at the time of the actual call (statically speaking)
- -- that we must do our static check, not at the time of
- -- its initial analysis). However, we have to check calls
- -- within component definitions (e.g., a function call
- -- that determines an array component bound), so we
+ -- Climb up the tree to make sure we are not inside default expression
+ -- of a parameter specification or a record component, since in both
+ -- these cases, we will be doing the actual call later, not now, and it
+ -- is at the time of the actual call (statically speaking) that we must
+ -- do our static check, not at the time of its initial analysis).
+
+ -- However, we have to check calls within component definitions (e.g., a
+ -- function call that determines an array component bound), so we
-- terminate the loop in that case.
P := Parent (N);
return;
-- Static model, call is not in elaboration code, we
- -- never need to worry, because in the static model
- -- the top level caller always takes care of things.
+ -- never need to worry, because in the static model the
+ -- top level caller always takes care of things.
else
return;
Process_Init_Proc : declare
Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
- function Process (Nod : Node_Id) return Traverse_Result;
- -- Find subprogram calls within body of init_proc for
- -- Traverse instantiation below.
+ function Find_Init_Call (Nod : Node_Id) return Traverse_Result;
+ -- Find subprogram calls within body of Init_Proc for Traverse
+ -- instantiation below.
- function Process (Nod : Node_Id) return Traverse_Result is
+ procedure Traverse_Body is new Traverse_Proc (Find_Init_Call);
+ -- Traversal procedure to find all calls with body of Init_Proc
+
+ --------------------
+ -- Find_Init_Call --
+ --------------------
+
+ function Find_Init_Call (Nod : Node_Id) return Traverse_Result is
Func : Entity_Id;
begin
else
return OK;
end if;
- end Process;
-
- procedure Traverse_Body is new Traverse_Proc (Process);
+ end Find_Init_Call;
-- Start of processing for Process_Init_Proc
end if;
end Check_Elab_Call;
+ -----------------------
+ -- Check_Elab_Assign --
+ -----------------------
+
+ procedure Check_Elab_Assign (N : Node_Id) is
+ Ent : Entity_Id;
+ Scop : Entity_Id;
+
+ Pkg_Spec : Entity_Id;
+ Pkg_Body : Entity_Id;
+
+ begin
+ -- For record or array component, check prefix. If it is an access
+ -- type, then there is nothing to do (we do not know what is being
+ -- assigned), but otherwise this is an assignment to the prefix.
+
+ if Nkind (N) = N_Indexed_Component
+ or else
+ Nkind (N) = N_Selected_Component
+ or else
+ Nkind (N) = N_Slice
+ then
+ if not Is_Access_Type (Etype (Prefix (N))) then
+ Check_Elab_Assign (Prefix (N));
+ end if;
+
+ return;
+ end if;
+
+ -- For type conversion, check expression
+
+ if Nkind (N) = N_Type_Conversion then
+ Check_Elab_Assign (Expression (N));
+ return;
+ end if;
+
+ -- Nothing to do if this is not an entity reference otherwise get entity
+
+ if Is_Entity_Name (N) then
+ Ent := Entity (N);
+ else
+ return;
+ end if;
+
+ -- What we are looking for is a reference in the body of a package that
+ -- modifies a variable declared in the visible part of the package spec.
+
+ if Present (Ent)
+ and then Comes_From_Source (N)
+ and then not Suppress_Elaboration_Warnings (Ent)
+ and then Ekind (Ent) = E_Variable
+ and then not In_Private_Part (Ent)
+ and then Is_Library_Level_Entity (Ent)
+ then
+ Scop := Current_Scope;
+ loop
+ if No (Scop) or else Scop = Standard_Standard then
+ return;
+ elsif Ekind (Scop) = E_Package
+ and then Is_Compilation_Unit (Scop)
+ then
+ exit;
+ else
+ Scop := Scope (Scop);
+ end if;
+ end loop;
+
+ -- Here Scop points to the containing library package
+
+ Pkg_Spec := Scop;
+ Pkg_Body := Body_Entity (Pkg_Spec);
+
+ -- All OK if the package has an Elaborate_Body pragma
+
+ if Has_Pragma_Elaborate_Body (Scop) then
+ return;
+ end if;
+
+ -- OK if entity being modified is not in containing package spec
+
+ if not In_Same_Source_Unit (Scop, Ent) then
+ return;
+ end if;
+
+ -- All OK if entity appears in generic package or generic instance.
+ -- We just get too messed up trying to give proper warnings in the
+ -- presence of generics. Better no message than a junk one.
+
+ Scop := Scope (Ent);
+ while Present (Scop) and then Scop /= Pkg_Spec loop
+ if Ekind (Scop) = E_Generic_Package then
+ return;
+ elsif Ekind (Scop) = E_Package
+ and then Is_Generic_Instance (Scop)
+ then
+ return;
+ end if;
+
+ Scop := Scope (Scop);
+ end loop;
+
+ -- All OK if in task, don't issue warnings there
+
+ if In_Task_Activation then
+ return;
+ end if;
+
+ -- OK if no package body
+
+ if No (Pkg_Body) then
+ return;
+ end if;
+
+ -- OK if reference is not in package body
+
+ if not In_Same_Source_Unit (Pkg_Body, N) then
+ return;
+ end if;
+
+ -- OK if package body has no handled statement sequence
+
+ declare
+ HSS : constant Node_Id :=
+ Handled_Statement_Sequence (Declaration_Node (Pkg_Body));
+ begin
+ if No (HSS) or else not Comes_From_Source (HSS) then
+ return;
+ end if;
+ end;
+
+ -- We definitely have a case of a modification of an entity in
+ -- the package spec from the elaboration code of the package body.
+ -- We may not give the warning (because there are some additional
+ -- checks to avoid too many false positives), but it would be a good
+ -- idea for the binder to try to keep the body elaboration close to
+ -- the spec elaboration.
+
+ Set_Elaborate_Body_Desirable (Pkg_Spec);
+
+ -- All OK in gnat mode (we know what we are doing)
+
+ if GNAT_Mode then
+ return;
+ end if;
+
+ -- All OK if warnings suppressed on the entity
+
+ if Warnings_Off (Ent) then
+ return;
+ end if;
+
+ -- All OK if all warnings suppressed
+
+ if Warning_Mode = Suppress then
+ return;
+ end if;
+
+ -- All OK if elaboration checks suppressed for entity
+
+ if Checks_May_Be_Suppressed (Ent)
+ and then Is_Check_Suppressed (Ent, Elaboration_Check)
+ then
+ return;
+ end if;
+
+ -- OK if the entity is initialized. Note that the No_Initialization
+ -- flag usually means that the initialization has been rewritten into
+ -- assignments, but that still counts for us.
+
+ declare
+ Decl : constant Node_Id := Declaration_Node (Ent);
+ begin
+ if Nkind (Decl) = N_Object_Declaration
+ and then (Present (Expression (Decl))
+ or else No_Initialization (Decl))
+ then
+ return;
+ end if;
+ end;
+
+ -- Here is where we give the warning
+
+ Error_Msg_Sloc := Sloc (Ent);
+
+ Error_Msg_NE
+ ("?elaboration code may access& before it is initialized",
+ N, Ent);
+ Error_Msg_NE
+ ("\?suggest adding pragma Elaborate_Body to spec of &",
+ N, Scop);
+ Error_Msg_N
+ ("\?or an explicit initialization could be added #", N);
+
+ if not All_Errors_Mode then
+ Set_Suppress_Elaboration_Warnings (Ent);
+ end if;
+ end if;
+ end Check_Elab_Assign;
+
----------------------
-- Check_Elab_Calls --
----------------------
Sbody : Node_Id;
Ebody : Entity_Id;
- function Process (N : Node_Id) return Traverse_Result;
- -- Function applied to each node as we traverse the body.
- -- Checks for call that needs checking, and if so checks
- -- it. Always returns OK, so entire tree is traversed.
+ function Find_Elab_Reference (N : Node_Id) return Traverse_Result;
+ -- Function applied to each node as we traverse the body. Checks for
+ -- call or entity reference that needs checking, and if so checks it.
+ -- Always returns OK, so entire tree is traversed, except that as
+ -- described below subprogram bodies are skipped for now.
+
+ procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference);
+ -- Traverse procedure using above Find_Elab_Reference function
+
+ -------------------------
+ -- Find_Elab_Reference --
+ -------------------------
- -------------
- -- Process --
- -------------
+ function Find_Elab_Reference (N : Node_Id) return Traverse_Result is
+ Actual : Node_Id;
- function Process (N : Node_Id) return Traverse_Result is
begin
-- If user has specified that there are no entry calls in elaboration
-- code, do not trace past an accept statement, because the rendez-
then
return Abandon;
- -- If we have a subprogram call, check it
+ -- If we have a function call, check it
- elsif Nkind (N) = N_Function_Call
- or else Nkind (N) = N_Procedure_Call_Statement
- then
+ elsif Nkind (N) = N_Function_Call then
+ Check_Elab_Call (N, Outer_Scope);
+ return OK;
+
+ -- If we have a procedure call, check the call, and also check
+ -- arguments that are assignments (OUT or IN OUT mode formals).
+
+ elsif Nkind (N) = N_Procedure_Call_Statement then
Check_Elab_Call (N, Outer_Scope);
+
+ Actual := First_Actual (N);
+ while Present (Actual) loop
+ if Known_To_Be_Assigned (Actual) then
+ Check_Elab_Assign (Actual);
+ end if;
+
+ Next_Actual (Actual);
+ end loop;
+
return OK;
-- If we have a generic instantiation, check it
then
return Skip;
+ elsif Nkind (N) = N_Assignment_Statement
+ and then Comes_From_Source (N)
+ then
+ Check_Elab_Assign (Name (N));
+ return OK;
+
else
return OK;
end if;
- end Process;
-
- procedure Traverse is new Atree.Traverse_Proc;
- -- Traverse procedure using above Process function
+ end Find_Elab_Reference;
-- Start of processing for Check_Internal_Call_Continue
Set_Elaboration_Flag (Sbody, E);
- -- Kill current value indication. This is necessary
- -- because the tests of this flag are inserted out of
- -- sequence and must not pick up bogus indications of
- -- the wrong constant value. Also, this is never a true
- -- constant, since one way or another, it gets reset.
+ -- Kill current value indication. This is necessary because
+ -- the tests of this flag are inserted out of sequence and
+ -- must not pick up bogus indications of the wrong constant
+ -- value. Also, this is never a true constant, since one way
+ -- or another, it gets reset.
Set_Current_Value (Ent, Empty);
+ Set_Last_Assignment (Ent, Empty);
Set_Is_True_Constant (Ent, False);
Pop_Scope;
end;
-- We only perform detailed checks in all tasks are library level
-- entities. If the master is a subprogram or task, activation will
-- depend on the activation of the master itself.
+
-- Should dynamic checks be added in the more general case???
if Ekind (Enclosing) /= E_Package then
-- object is the first actual in the call.
declare
- Typ : constant Entity_Id :=
- Etype (First (Parameter_Associations (Call)));
+ Typ : constant Entity_Id :=
+ Etype (First (Parameter_Associations (Call)));
begin
Elab_Unit := Scope (Typ);
while (Present (Elab_Unit))
projects / platform / upstream / linaro-gcc.git / commitdiff