OpenE2K
/
gcc
2
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

sem_elab.ads, [...] (Check_Elab_Assign): New procedure Add new calls to this procedure during traversal 

2006-10-31  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* sem_elab.ads, sem_elab.adb (Check_Elab_Assign): New procedure
	Add new calls to this procedure during traversal
	(Activate_Elaborate_All_Desirable): Do not set elaboration flag on
	another unit if expansion is disabled.

From-SVN: r118309
This commit is contained in:
Robert Dewar 2006-10-31 19:09:19 +01:00 committed by Arnaud Charlet
parent 67f3c450aa
commit a5abb241f3
2 changed files with 289 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

318
gcc/ada/sem_elab.adb
View File

@ -403,6 +403,13 @@ package body Sem_Elab is
-- 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
@ -1150,15 +1157,14 @@ package body Sem_Elab is
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);
@ -1327,8 +1333,8 @@ package body Sem_Elab is
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;
@ -1422,11 +1428,18 @@ package body Sem_Elab is
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
@ -1446,9 +1459,7 @@ package body Sem_Elab is
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
@ -1460,6 +1471,205 @@ package body Sem_Elab is
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 --
----------------------
@ -1690,16 +1900,22 @@ package body Sem_Elab is
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.
-------------
-- Process --
-------------
procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference);
-- Traverse procedure using above Find_Elab_Reference function
-------------------------
-- Find_Elab_Reference --
-------------------------
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-
@ -1711,14 +1927,29 @@ package body Sem_Elab is
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
elsif Nkind (N) in N_Generic_Instantiation then
@ -1741,13 +1972,16 @@ package body Sem_Elab is
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
@ -1893,13 +2127,14 @@ package body Sem_Elab is
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;
@ -2118,6 +2353,7 @@ package body Sem_Elab is
-- 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
@ -2252,8 +2488,8 @@ package body Sem_Elab is
-- 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))

18
gcc/ada/sem_elab.ads
View File

@ -6,7 +6,7 @@
-- --
-- S p e c --
-- --
-- Copyright (C) 1997-2005, Free Software Foundation, Inc. --
-- Copyright (C) 1997-2006, Free Software Foundation, Inc. --
-- --
-- GNAT is free software; you can redistribute it and/or modify it under --
-- terms of the GNU General Public License as published by the Free Soft- --
@ -120,11 +120,11 @@ package Sem_Elab is
-- corresponding bodies.
procedure Check_Elab_Call (N : Node_Id; Outer_Scope : Entity_Id := Empty);
-- Check a call for possible elaboration problems. N is either an
-- N_Function_Call or N_Procedure_Call_Statement node, and Outer
-- indicates whether this is an outer level call from Sem_Res
-- (Outer_Scope set to Empty), or an internal recursive call
-- (Outer_Scope set to entity of outermost call, see body).
-- Check a call for possible elaboration problems. The node N is either
-- an N_Function_Call or N_Procedure_Call_Statement node. The Outer_Scope
-- argument indicates whether this is an outer level call from Sem_Res
-- (Outer_Scope set to Empty), or an internal recursive call (Outer_Scope
-- set to entity of outermost call, see body).
procedure Check_Elab_Calls;
-- Not all the processing for Check_Elab_Call can be done at the time
@ -133,6 +133,12 @@ package Sem_Elab is
-- instantiated. The Check_Elab_Calls procedure cleans up these waiting
-- checks. It is called once after the completion of instantiation.
procedure Check_Elab_Assign (N : Node_Id);
-- N is either the left side of an assignment, or a procedure argument for
-- a mode OUT or IN OUT formal. This procedure checks for a possible case
-- of access to an entity from elaboration code before the entity has been
-- initialized, and issues appropriate warnings.
procedure Check_Elab_Instantiation
(N : Node_Id;
Outer_Scope : Entity_Id := Empty);