+ -----------------------
+ -- 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 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
+
+ -- All OK if warnings suppressed on the entity
+
+ if not Has_Warnings_Off (Ent) then
+ 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);
+ end if;
+
+ if not All_Errors_Mode then
+ Set_Suppress_Elaboration_Warnings (Ent);
+ end if;
+ end if;
+ end Check_Elab_Assign;
+