-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2007, 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- --
-- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
-- for more details. You should have received a copy of the GNU General --
-- Public License distributed with GNAT; see file COPYING. If not, write --
--- to the Free Software Foundation, 59 Temple Place - Suite 330, Boston, --
--- MA 02111-1307, USA. --
+-- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
+-- Boston, MA 02110-1301, USA. --
-- --
-- GNAT was originally developed by the GNAT team at New York University. --
-- Extensive contributions were provided by Ada Core Technologies Inc. --
with Einfo; use Einfo;
with Elists; use Elists;
with Errout; use Errout;
+with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Expander; use Expander;
with Fname; use Fname;
with Opt; use Opt;
with Output; use Output;
with Restrict; use Restrict;
+with Rident; use Rident;
with Sem; use Sem;
with Sem_Cat; use Sem_Cat;
with Sem_Ch7; use Sem_Ch7;
Outer_Scope : Entity_Id;
-- Save scope of outer level call
-
end record;
package Delay_Check is new Table.Table (
-- Local Subprograms --
-----------------------
- -- Note: Outer_Scope in all these calls represents the scope of
+ -- Note: Outer_Scope in all following specs represents the scope of
-- interest of the outer level call. If it is set to Standard_Standard,
-- then it means the outer level call was at elaboration level, and that
-- thus all calls are of interest. If it was set to some other scope,
-- then the original call was an inner call, and we are not interested
-- in calls that go outside this scope.
+ procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id);
+ -- Analysis of construct N shows that we should set Elaborate_All_Desirable
+ -- for the WITH clause for unit U (which will always be present). A special
+ -- case is when N is a function or procedure instantiation, in which case
+ -- it is sufficient to set Elaborate_Desirable, since in this case there is
+ -- no possibility of transitive elaboration issues.
+
procedure Check_A_Call
(N : Node_Id;
E : Entity_Id;
-- to Check_Internal_Call. Outer_Scope is the outer level scope for
-- the original call.
+ procedure Set_Elaboration_Constraint
+ (Call : Node_Id;
+ Subp : Entity_Id;
+ Scop : Entity_Id);
+ -- The current unit U may depend semantically on some unit P which is not
+ -- in the current context. If there is an elaboration call that reaches P,
+ -- we need to indicate that P requires an Elaborate_All, but this is not
+ -- effective in U's ali file, if there is no with_clause for P. In this
+ -- case we add the Elaborate_All on the unit Q that directly or indirectly
+ -- makes P available. This can happen in two cases:
+ --
+ -- a) Q declares a subtype of a type declared in P, and the call is an
+ -- initialization call for an object of that subtype.
+ --
+ -- b) Q declares an object of some tagged type whose root type is
+ -- declared in P, and the initialization call uses object notation on
+ -- that object to reach a primitive operation or a classwide operation
+ -- declared in P.
+ --
+ -- If P appears in the context of U, the current processing is correct.
+ -- Otherwise we must identify these two cases to retrieve Q and place the
+ -- Elaborate_All_Desirable on it.
+
function Has_Generic_Body (N : Node_Id) return Boolean;
-- N is a generic package instantiation node, and this routine determines
-- if this package spec does in fact have a generic body. If so, then
-- convention Stubbed.
procedure Supply_Bodies (L : List_Id);
- -- Calls Supply_Bodies for all elements of the given list L.
+ -- Calls Supply_Bodies for all elements of the given list L
function Within (E1, E2 : Entity_Id) return Boolean;
- -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or
- -- is one of its contained scopes, False otherwise.
+ -- Given two scopes E1 and E2, returns True if E1 is equal to E2, or is one
+ -- of its contained scopes, False otherwise.
function Within_Elaborate_All (E : Entity_Id) return Boolean;
-- Before emitting a warning on a scope E for a missing elaborate_all,
- -- check whether E may be in the context of a directly visible unit
- -- U to which the pragma applies. This prevents spurious warnings when
- -- the called entity is renamed within U.
+ -- check whether E may be in the context of a directly visible unit U to
+ -- which the pragma applies. This prevents spurious warnings when the
+ -- called entity is renamed within U.
+
+ --------------------------------------
+ -- Activate_Elaborate_All_Desirable --
+ --------------------------------------
+
+ procedure Activate_Elaborate_All_Desirable (N : Node_Id; U : Entity_Id) is
+ UN : constant Unit_Number_Type := Get_Code_Unit (N);
+ CU : constant Node_Id := Cunit (UN);
+ UE : constant Entity_Id := Cunit_Entity (UN);
+ Unm : constant Unit_Name_Type := Unit_Name (UN);
+ CI : constant List_Id := Context_Items (CU);
+ Itm : Node_Id;
+ Ent : Entity_Id;
+
+ procedure Add_To_Context_And_Mark (Itm : Node_Id);
+ -- This procedure is called when the elaborate indication must be
+ -- applied to a unit not in the context of the referencing unit. The
+ -- unit gets added to the context as an implicit with.
+
+ function In_Withs_Of (UEs : Entity_Id) return Boolean;
+ -- UEs is the spec entity of a unit. If the unit to be marked is
+ -- in the context item list of this unit spec, then the call returns
+ -- True and Itm is left set to point to the relevant N_With_Clause node.
+
+ procedure Set_Elab_Flag (Itm : Node_Id);
+ -- Sets Elaborate_[All_]Desirable as appropriate on Itm
+
+ -----------------------------
+ -- Add_To_Context_And_Mark --
+ -----------------------------
+
+ procedure Add_To_Context_And_Mark (Itm : Node_Id) is
+ CW : constant Node_Id :=
+ Make_With_Clause (Sloc (Itm),
+ Name => Name (Itm));
+
+ begin
+ Set_Library_Unit (CW, Library_Unit (Itm));
+ Set_Implicit_With (CW, True);
+
+ -- Set elaborate all desirable on copy and then append the copy to
+ -- the list of body with's and we are done.
+
+ Set_Elab_Flag (CW);
+ Append_To (CI, CW);
+ end Add_To_Context_And_Mark;
+
+ -----------------
+ -- In_Withs_Of --
+ -----------------
+
+ function In_Withs_Of (UEs : Entity_Id) return Boolean is
+ UNs : constant Unit_Number_Type := Get_Source_Unit (UEs);
+ CUs : constant Node_Id := Cunit (UNs);
+ CIs : constant List_Id := Context_Items (CUs);
+
+ begin
+ Itm := First (CIs);
+ while Present (Itm) loop
+ if Nkind (Itm) = N_With_Clause then
+ Ent :=
+ Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm)));
+
+ if U = Ent then
+ return True;
+ end if;
+ end if;
+
+ Next (Itm);
+ end loop;
+
+ return False;
+ end In_Withs_Of;
+
+ -------------------
+ -- Set_Elab_Flag --
+ -------------------
+
+ procedure Set_Elab_Flag (Itm : Node_Id) is
+ begin
+ if Nkind (N) in N_Subprogram_Instantiation then
+ Set_Elaborate_Desirable (Itm);
+ else
+ Set_Elaborate_All_Desirable (Itm);
+ end if;
+ end Set_Elab_Flag;
+
+ -- 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
+ Ent := Cunit_Entity (Get_Cunit_Unit_Number (Library_Unit (Itm)));
+
+ -- If we find it, then mark elaborate all desirable and return
+
+ if U = Ent then
+ Set_Elab_Flag (Itm);
+ return;
+ end if;
+ end if;
+
+ Next (Itm);
+ end loop;
+
+ -- If we fall through then the with clause is not present in the
+ -- current unit. One legitimate possibility is that the with clause
+ -- is present in the spec when we are a body.
+
+ if Is_Body_Name (Unm)
+ and then In_Withs_Of (Spec_Entity (UE))
+ then
+ Add_To_Context_And_Mark (Itm);
+ return;
+ end if;
+
+ -- Similarly, we may be in the spec or body of a child unit, where
+ -- the unit in question is with'ed by some ancestor of the child unit.
+
+ if Is_Child_Name (Unm) then
+ declare
+ Pkg : Entity_Id;
+
+ begin
+ Pkg := UE;
+ loop
+ Pkg := Scope (Pkg);
+ exit when Pkg = Standard_Standard;
+
+ if In_Withs_Of (Pkg) then
+ Add_To_Context_And_Mark (Itm);
+ return;
+ end if;
+ end loop;
+ end;
+ end if;
+
+ -- Here if we do not find with clause on spec or body. We just ignore
+ -- this case, it means that the elaboration involves some other unit
+ -- than the unit being compiled, and will be caught elsewhere.
+
+ null;
+ end Activate_Elaborate_All_Desirable;
------------------
-- Check_A_Call --
Decl : Node_Id;
E_Scope : Entity_Id;
- -- Top level scope of entity for called subprogram
+ -- Top level scope of entity for called subprogram. This
+ -- value includes following renamings and derivations, so
+ -- this scope can be in a non-visible unit. This is the
+ -- scope that is to be investigated to see whether an
+ -- elaboration check is required.
+
+ W_Scope : Entity_Id;
+ -- Top level scope of directly called entity for subprogram. This
+ -- differs from E_Scope in the case where renamings or derivations
+ -- are involved, since it does not follow these links. W_Scope is
+ -- generally in a visible unit, and it is this scope that may require
+ -- an Elaborate_All. However, there are some cases (initialization
+ -- calls and calls involving object notation) where W_Scope might not
+ -- be in the context of the current unit, and there is an intermediate
+ -- package that is, in which case the Elaborate_All has to be placed
+ -- on this intedermediate package. These special cases are handled in
+ -- Set_Elaboration_Constraint.
Body_Acts_As_Spec : Boolean;
-- Set to true if call is to body acting as spec (no separate spec)
Unit_Caller : Unit_Number_Type;
Unit_Callee : Unit_Number_Type;
- Cunit_SW : Boolean := False;
- -- Set to suppress warnings for case of external reference where
- -- one of the enclosing scopes has the Suppress_Elaboration_Warnings
- -- flag set. For the internal case, we ignore this flag.
-
Cunit_SC : Boolean := False;
-- Set to suppress dynamic elaboration checks where one of the
- -- enclosing scopes has Suppress_Elaboration_Checks set. For
- -- the internal case, we ignore this flag.
+ -- enclosing scopes has Elaboration_Checks_Suppressed set, or else
+ -- if a pragma Elaborate (_All) applies to that scope, in which case
+ -- warnings on the scope are also suppressed. For the internal case,
+ -- we ignore this flag.
begin
+ -- If the call is known to be within a local Suppress Elaboration
+ -- pragma, nothing to check. This can happen in task bodies.
+
+ if (Nkind (N) = N_Function_Call
+ or else Nkind (N) = N_Procedure_Call_Statement)
+ and then No_Elaboration_Check (N)
+ then
+ return;
+ end if;
+
-- Go to parent for derived subprogram, or to original subprogram
-- in the case of a renaming (Alias covers both these cases)
Ent := E;
loop
- if Suppress_Elaboration_Warnings (Ent) then
+ if (Suppress_Elaboration_Warnings (Ent)
+ or else Elaboration_Checks_Suppressed (Ent))
+ and then (Inst_Case or else No (Alias (Ent)))
+ then
return;
end if;
- -- Nothing to do for imported entities,
+ -- Nothing to do for imported entities
if Is_Imported (Ent) then
return;
E_Scope := Ent;
loop
- if Suppress_Elaboration_Warnings (E_Scope) then
- Cunit_SW := True;
- end if;
-
- if Suppress_Elaboration_Checks (E_Scope) then
+ if Elaboration_Checks_Suppressed (E_Scope)
+ or else Suppress_Elaboration_Warnings (E_Scope)
+ then
Cunit_SC := True;
end if;
-- If the generic entity is within a deeper instance than we are, then
-- either the instantiation to which we refer itself caused an ABE, in
- -- which case that will be handled separately. Otherwise, we know that
- -- the body we need appears as needed at the point of the instantiation.
+ -- which case that will be handled separately, or else we know that the
+ -- body we need appears as needed at the point of the instantiation.
-- However, this assumption is only valid if we are in static mode.
if not Dynamic_Elaboration_Checks
return;
end if;
- -- Nothing to do if some scope said to ignore warnings
+ -- Nothing to do if some scope said that no checks were required
- if Cunit_SW then
+ if Cunit_SC then
return;
end if;
return;
end if;
- -- Nothing to do if subprogram with no separate spec
+ -- Nothing to do if subprogram with no separate spec. However,
+ -- a call to Deep_Initialize may result in a call to a user-defined
+ -- Initialize procedure, which imposes a body dependency. This
+ -- happens only if the type is controlled and the Initialize
+ -- procedure is not inherited.
if Body_Acts_As_Spec then
- return;
+ if Is_TSS (Ent, TSS_Deep_Initialize) then
+ declare
+ Typ : Entity_Id;
+ Init : Entity_Id;
+ begin
+ Typ := Etype (Next_Formal (First_Formal (Ent)));
+
+ if not Is_Controlled (Typ) then
+ return;
+ else
+ Init := Find_Prim_Op (Typ, Name_Initialize);
+
+ if Comes_From_Source (Init) then
+ Ent := Init;
+ else
+ return;
+ end if;
+ end if;
+ end;
+
+ else
+ return;
+ end if;
end if;
-- Check cases of internal units
return;
end if;
- Ent := E;
+ if Is_TSS (E, TSS_Deep_Initialize) then
+ Ent := E;
+ end if;
-- If the call is in an instance, and the called entity is not
-- defined in the same instance, then the elaboration issue
exit when E_Scope /= C_Scope;
Ent := Alias (Ent);
E_Scope := Ent;
+
+ -- If no alias, there is a previous error
+
+ if No (Ent) then
+ return;
+ end if;
end loop;
end if;
return;
end if;
+ -- Find top level scope for called entity (not following renamings
+ -- or derivations). This is where the Elaborate_All will go if it
+ -- is needed. We start with the called entity, except in the case
+ -- of an initialization procedure outside the current package, where
+ -- the init proc is in the root package, and we start from the entity
+ -- of the name in the call.
+
+ if Is_Entity_Name (Name (N))
+ and then Is_Init_Proc (Entity (Name (N)))
+ and then not In_Same_Extended_Unit (N, Entity (Name (N)))
+ then
+ W_Scope := Scope (Entity (Name (N)));
+ else
+ W_Scope := E;
+ end if;
+
+ while not Is_Compilation_Unit (W_Scope) loop
+ W_Scope := Scope (W_Scope);
+ end loop;
+
+ -- Now check if an elaborate_all (or dynamic check) is needed
+
if not Suppress_Elaboration_Warnings (Ent)
+ and then not Elaboration_Checks_Suppressed (Ent)
and then not Suppress_Elaboration_Warnings (E_Scope)
+ and then not Elaboration_Checks_Suppressed (E_Scope)
and then Elab_Warnings
and then Generate_Warnings
then
- Warn_On_Instance := True;
+ Generate_Elab_Warnings : declare
+ procedure Elab_Warning
+ (Msg_D : String;
+ Msg_S : String;
+ Ent : Node_Or_Entity_Id);
+ -- Generate a call to Error_Msg_NE with parameters Msg_D or
+ -- Msg_S (for dynamic or static elaboration model), N and Ent.
+
+ ------------------
+ -- Elab_Warning --
+ ------------------
+
+ procedure Elab_Warning
+ (Msg_D : String;
+ Msg_S : String;
+ Ent : Node_Or_Entity_Id)
+ is
+ begin
+ if Dynamic_Elaboration_Checks then
+ Error_Msg_NE (Msg_D, N, Ent);
+ else
+ Error_Msg_NE (Msg_S, N, Ent);
+ end if;
+ end Elab_Warning;
- if Inst_Case then
- Error_Msg_NE
- ("instantiation of& may raise Program_Error?", N, Ent);
- else
- Error_Msg_NE
- ("call to & may raise Program_Error?", N, Ent);
+ -- Start of processing for Generate_Elab_Warnings
- if Unit_Callee = No_Unit
- and then E_Scope = Current_Scope
- then
- -- The missing pragma cannot be on the current unit, so
- -- place it on the compilation unit that contains the
- -- called entity, which is more likely to be right.
+ begin
+ if Inst_Case then
+ Elab_Warning
+ ("instantiation of& may raise Program_Error?",
+ "instantiation of& during elaboration?", Ent);
+
+ else
+ if Nkind (Name (N)) in N_Has_Entity
+ and then Is_Init_Proc (Entity (Name (N)))
+ and then Comes_From_Source (Ent)
+ then
+ Elab_Warning
+ ("implicit call to & may raise Program_Error?",
+ "implicit call to & during elaboration?",
+ Ent);
- E_Scope := Ent;
+ else
+ Elab_Warning
+ ("call to & may raise Program_Error?",
+ "call to & during elaboration?",
+ Ent);
+ end if;
+ end if;
+
+ Error_Msg_Qual_Level := Nat'Last;
- while not Is_Compilation_Unit (E_Scope) loop
- E_Scope := Scope (E_Scope);
- end loop;
+ if Nkind (N) in N_Subprogram_Instantiation then
+ Elab_Warning
+ ("\missing pragma Elaborate for&?",
+ "\implicit pragma Elaborate for& generated?",
+ W_Scope);
+ else
+ Elab_Warning
+ ("\missing pragma Elaborate_All for&?",
+ "\implicit pragma Elaborate_All for & generated?",
+ W_Scope);
end if;
- end if;
+ end Generate_Elab_Warnings;
- Error_Msg_Qual_Level := Nat'Last;
- Error_Msg_NE
- ("\missing pragma Elaborate_All for&?", N, E_Scope);
Error_Msg_Qual_Level := 0;
Output_Calls (N);
- Warn_On_Instance := False;
- -- Set flag to prevent further warnings for same unit
- -- unless in All_Errors_Mode.
+ -- Set flag to prevent further warnings for same unit unless in
+ -- All_Errors_Mode.
if not All_Errors_Mode and not Dynamic_Elaboration_Checks then
- Set_Suppress_Elaboration_Warnings (E_Scope);
+ Set_Suppress_Elaboration_Warnings (W_Scope, True);
end if;
end if;
if Dynamic_Elaboration_Checks then
if not Elaboration_Checks_Suppressed (Ent)
- and then not Suppress_Elaboration_Checks (E_Scope)
+ and then not Elaboration_Checks_Suppressed (W_Scope)
+ and then not Elaboration_Checks_Suppressed (E_Scope)
and then not Cunit_SC
then
- -- Runtime elaboration check required. generate check of the
+ -- Runtime elaboration check required. Generate check of the
-- elaboration Boolean for the unit containing the entity.
+ -- Note that for this case, we do check the real unit (the
+ -- one from following renamings, since that is the issue!)
+
+ -- Could this possibly miss a useless but required PE???
+
Insert_Elab_Check (N,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Elaborated,
(Spec_Entity (E_Scope), Loc)));
end if;
- -- If no dynamic check required, then ask binder to guarantee
- -- that the necessary elaborations will be done properly!
+ -- Case of static elaboration model
else
- if not Suppress_Elaboration_Warnings (E)
- and then not Suppress_Elaboration_Warnings (E_Scope)
- and then Elab_Warnings
- and then Generate_Warnings
- and then not Inst_Case
+ -- Do not do anything if elaboration checks suppressed. Note
+ -- that we check Ent here, not E, since we want the real entity
+ -- for the body to see if checks are suppressed for it, not the
+ -- dummy entry for renamings or derivations.
+
+ if Elaboration_Checks_Suppressed (Ent)
+ or else Elaboration_Checks_Suppressed (E_Scope)
+ or else Elaboration_Checks_Suppressed (W_Scope)
then
- Error_Msg_Node_2 := E_Scope;
- Error_Msg_NE ("call to& in elaboration code " &
- "requires pragma Elaborate_All on&?", N, E);
- end if;
+ null;
+
+ -- Here we need to generate an implicit elaborate all
- Set_Elaborate_All_Desirable (E_Scope);
- Set_Suppress_Elaboration_Warnings (E_Scope);
+ else
+ -- Generate elaborate_all warning unless suppressed
+
+ if (Elab_Warnings and Generate_Warnings and not Inst_Case)
+ and then not Suppress_Elaboration_Warnings (Ent)
+ and then not Suppress_Elaboration_Warnings (E_Scope)
+ and then not Suppress_Elaboration_Warnings (W_Scope)
+ then
+ Error_Msg_Node_2 := W_Scope;
+ Error_Msg_NE
+ ("call to& in elaboration code " &
+ "requires pragma Elaborate_All on&?", N, E);
+ end if;
+
+ -- Set indication for binder to generate Elaborate_All
+
+ Set_Elaboration_Constraint (N, E, W_Scope);
+ end if;
end if;
-- Case of entity is in same unit as call or instantiation
elsif not Inter_Unit_Only then
Check_Internal_Call (N, Ent, Outer_Scope, E);
end if;
-
end Check_A_Call;
-----------------------------
-----------------------------
procedure Check_Bad_Instantiation (N : Node_Id) is
- Nam : Node_Id;
Ent : Entity_Id;
begin
return;
end if;
- Nam := Name (N);
Ent := Get_Generic_Entity (N);
-- The case we are interested in is when the generic spec is in the
-- current declarative part
if not Same_Elaboration_Scope (Current_Scope, Scope (Ent))
- or else not In_Same_Extended_Unit (Sloc (N), Sloc (Ent))
+ or else not In_Same_Extended_Unit (N, Ent)
then
return;
end if;
("\?Program_Error will be raised at run time", N);
Insert_Elab_Check (N);
Set_ABE_Is_Certain (N);
-
end Check_Bad_Instantiation;
---------------------
(N : Node_Id;
Outer_Scope : Entity_Id := Empty)
is
- Nam : Node_Id;
Ent : Entity_Id;
P : Node_Id;
+ function Get_Called_Ent return Entity_Id;
+ -- Retrieve called entity. If this is a call to a protected subprogram,
+ -- entity is a selected component. The callable entity may be absent,
+ -- in which case there is no check to perform. This happens with
+ -- non-analyzed calls in nested generics.
+
+ --------------------
+ -- Get_Called_Ent --
+ --------------------
+
+ function Get_Called_Ent return Entity_Id is
+ Nam : Node_Id;
+
+ begin
+ Nam := Name (N);
+
+ if No (Nam) then
+ return Empty;
+
+ elsif Nkind (Nam) = N_Selected_Component then
+ return Entity (Selector_Name (Nam));
+
+ elsif not Is_Entity_Name (Nam) then
+ return Empty;
+
+ else
+ return Entity (Nam);
+ end if;
+ end Get_Called_Ent;
+
+ -- Start of processing for Check_Elab_Call
+
begin
+ -- If the call does not come from the main unit, there is nothing to
+ -- check. Elaboration call from units in the context of the main unit
+ -- will lead to semantic dependencies when those units are compiled.
+
+ if not In_Extended_Main_Code_Unit (N) then
+ return;
+ end if;
+
-- For an entry call, check relevant restriction
if Nkind (N) = N_Entry_Call_Statement
then
return;
- -- Nothing to do if this is a call already rewritten for elab checking.
+ -- Nothing to do if this is a call already rewritten for elab checking
elsif Nkind (Parent (N)) = N_Conditional_Expression then
return;
-- Nothing to do if inside a generic template
elsif Inside_A_Generic
- and then not Present (Enclosing_Generic_Body (N))
+ and then No (Enclosing_Generic_Body (N))
then
return;
end if;
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).
+ -- 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);
while Present (P) loop
Nkind (P) = N_Component_Declaration
then
return;
+
+ -- The call occurs within the constraint of a component,
+ -- so it must be checked.
+
+ elsif Nkind (P) = N_Component_Definition then
+ exit;
+
else
P := Parent (P);
end if;
-- First case, we are in elaboration code
From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
-
if From_Elab_Code then
-- Complain if call that comes from source in preelaborated
and then In_Preelaborated_Unit
and then not In_Inlined_Body
then
+ -- This is a warning in GNAT mode allowing such calls to be
+ -- used in the predefined library with appropriate care.
+
+ Error_Msg_Warn := GNAT_Mode;
Error_Msg_N
- ("non-static call not allowed in preelaborated unit", N);
+ ("<non-static call not allowed in preelaborated unit", N);
return;
end if;
- -- Second case, we are inside a subprogram or concurrent unit
- -- i.e, we are not in elaboration code.
+ -- Second case, we are inside a subprogram or concurrent unit, which
+ -- means we are not in elaboration code.
else
-- In this case, the issue is whether we are inside the
- -- declarative part of the unit in which we live, or inside
- -- its statements. In the latter case, there is no issue of
- -- ABE calls at this level (a call from outside to the unit
- -- in which we live might cause an ABE, but that will be
- -- detected when we analyze that outer level call, as it
- -- recurses into the called unit).
+ -- declarative part of the unit in which we live, or inside its
+ -- statements. In the latter case, there is no issue of ABE calls
+ -- at this level (a call from outside to the unit in which we live
+ -- might cause an ABE, but that will be detected when we analyze
+ -- that outer level call, as it recurses into the called unit).
- -- Climb up the tree, doing this test, and also testing
- -- for being inside a default expression, which, as
- -- discussed above, is not checked at this stage.
+ -- Climb up the tree, doing this test, and also testing for being
+ -- inside a default expression, which, as discussed above, is not
+ -- checked at this stage.
declare
P : Node_Id;
begin
P := N;
loop
- -- If we find a parentless subtree, it seems safe to
- -- assume that we are not in a declarative part and
- -- that no checking is required.
+ -- If we find a parentless subtree, it seems safe to assume
+ -- that we are not in a declarative part and that no
+ -- checking is required.
if No (P) then
return;
exit when Nkind (P) = N_Subunit;
- -- Filter out case of default expressions, where
- -- we do not do the check at this stage.
+ -- Filter out case of default expressions, where we do not
+ -- do the check at this stage.
if Nkind (P) = N_Parameter_Specification
or else
return;
end if;
- if Nkind (P) = N_Subprogram_Body
- or else
- Nkind (P) = N_Protected_Body
+ -- A protected body has no elaboration code and contains
+ -- only other bodies.
+
+ if Nkind (P) = N_Protected_Body then
+ return;
+
+ elsif Nkind (P) = N_Subprogram_Body
or else
Nkind (P) = N_Task_Body
or else
Nkind (P) = N_Block_Statement
+ or else
+ Nkind (P) = N_Entry_Body
then
if L = Declarations (P) then
exit;
elsif Dynamic_Elaboration_Checks then
-- This is a rather new check, going into version
- -- 3.14a1 for the first time (V1.80 of this unit),
- -- so we provide a debug flag to enable it. That
- -- way we have an easy work around for regressions
- -- that are caused by this new check. This debug
- -- flag can be removed later.
+ -- 3.14a1 for the first time (V1.80 of this unit), so
+ -- we provide a debug flag to enable it. That way we
+ -- have an easy work around for regressions that are
+ -- caused by this new check. This debug flag can be
+ -- removed later.
if Debug_Flag_DD then
return;
exit;
+ elsif Nkind (P) = N_Task_Body then
+
+ -- The check is deferred until Check_Task_Activation
+ -- but we need to capture local suppress pragmas
+ -- that may inhibit checks on this call.
+
+ Ent := Get_Called_Ent;
+
+ if No (Ent) then
+ return;
+
+ elsif Elaboration_Checks_Suppressed (Current_Scope)
+ or else Elaboration_Checks_Suppressed (Ent)
+ or else Elaboration_Checks_Suppressed (Scope (Ent))
+ then
+ Set_No_Elaboration_Check (N);
+ end if;
+
+ 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;
end if;
end if;
- -- Retrieve called entity. If this is a call to a protected subprogram,
- -- the entity is a selected component.
- -- The callable entity may be absent, in which case there is nothing
- -- to do. This happens with non-analyzed calls in nested generics.
-
- Nam := Name (N);
-
- if No (Nam) then
- return;
-
- elsif Nkind (Nam) = N_Selected_Component then
- Ent := Entity (Selector_Name (Nam));
-
- elsif not Is_Entity_Name (Nam) then
- return;
-
- else
- Ent := Entity (Nam);
- end if;
+ Ent := Get_Called_Ent;
if No (Ent) then
return;
Inter_Unit_Only => True,
Generate_Warnings => False);
+ -- Otherwise nothing to do
+
else
return;
end if;
+
+ -- A call to an Init_Proc in elaboration code may bring additional
+ -- dependencies, if some of the record components thereof have
+ -- initializations that are function calls that come from source.
+ -- We treat the current node as a call to each of these functions,
+ -- to check their elaboration impact.
+
+ if Is_Init_Proc (Ent)
+ and then From_Elab_Code
+ then
+ Process_Init_Proc : declare
+ Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent);
+
+ function Find_Init_Call (Nod : Node_Id) return Traverse_Result;
+ -- Find subprogram calls within body of Init_Proc for Traverse
+ -- instantiation below.
+
+ 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
+ if (Nkind (Nod) = N_Function_Call
+ or else Nkind (Nod) = N_Procedure_Call_Statement)
+ and then Is_Entity_Name (Name (Nod))
+ then
+ Func := Entity (Name (Nod));
+
+ if Comes_From_Source (Func) then
+ Check_A_Call
+ (N, Func, Standard_Standard, Inter_Unit_Only => True);
+ end if;
+
+ return OK;
+
+ else
+ return OK;
+ end if;
+ end Find_Init_Call;
+
+ -- Start of processing for Process_Init_Proc
+
+ begin
+ if Nkind (Unit_Decl) = N_Subprogram_Body then
+ Traverse_Body (Handled_Statement_Sequence (Unit_Decl));
+ end if;
+ end 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 --
----------------------
-- case we lack the full information that we need, and no object
-- file will be created in any case.
- if not Expander_Active or else Subunits_Missing then
+ if not Expander_Active
+ or else Is_Generic_Unit (Cunit_Entity (Main_Unit))
+ or else Subunits_Missing
+ then
return;
end if;
Expander_Mode_Save_And_Set (True);
for J in Delay_Check.First .. Delay_Check.Last loop
- New_Scope (Delay_Check.Table (J).Curscop);
+ Push_Scope (Delay_Check.Table (J).Curscop);
From_Elab_Code := Delay_Check.Table (J).From_Elab_Code;
Check_Internal_Call_Continue (
(N : Node_Id;
Outer_Scope : Entity_Id := Empty)
is
- Nam : Node_Id;
- Ent : Entity_Id;
+ Ent : Entity_Id;
begin
-- Check for and deal with bad instantiation case. There is some
return;
end if;
- Nam := Name (N);
+ -- Nothing to do if the instantiation is not in the main unit
+
+ if not In_Extended_Main_Code_Unit (N) then
+ return;
+ end if;
+
Ent := Get_Generic_Entity (N);
From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
else
Check_Internal_Call_Continue (N, E, Outer_Scope, Orig_Ent);
end if;
-
end Check_Internal_Call;
----------------------------------
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 --
+ -------------------------
+
+ 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-
if (Nkind (Original_Node (N)) = N_Accept_Statement
or else Nkind (Original_Node (N)) = N_Selective_Accept)
- and then Restrictions (No_Entry_Calls_In_Elaboration_Code)
+ and then Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
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
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
-- does not normally visit subprogram bodies.
declare
- Decl : Node_Id := First (Declarations (Sbody));
-
+ Decl : Node_Id;
begin
+ Decl := First (Declarations (Sbody));
while Present (Decl) loop
Traverse (Decl);
Next (Decl);
-- Here is the case of calling a subprogram where the body has
-- not yet been encountered, a warning message is needed.
- Warn_On_Instance := True;
-
-- If we have nothing in the call stack, then this is at the
-- outer level, and the ABE is bound to occur.
if Elab_Call.Last = 0 then
-
if Inst_Case then
Error_Msg_NE
("?cannot instantiate& before body seen", N, Orig_Ent);
begin
Set_Elaboration_Entity (E, Ent);
- New_Scope (Scope (E));
+ Push_Scope (Scope (E));
Insert_Action (Declaration_Node (E),
Make_Object_Declaration (Loce,
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.
+
+ Set_Current_Value (Ent, Empty);
+ Set_Last_Assignment (Ent, Empty);
+ Set_Is_True_Constant (Ent, False);
Pop_Scope;
end;
end if;
-- Generate the warning
- if not Suppress_Elaboration_Warnings (E) then
+ if not Suppress_Elaboration_Warnings (E)
+ and then not Elaboration_Checks_Suppressed (E)
+ then
if Inst_Case then
Error_Msg_NE
("instantiation of& may occur before body is seen?",
end if;
end if;
- Warn_On_Instance := False;
-
-- Set flag to suppress further warnings on same subprogram
-- unless in all errors mode
end if;
end Check_Internal_Call_Continue;
- ----------------------------
- -- Check_Task_Activation --
- ----------------------------
+ ---------------------------
+ -- Check_Task_Activation --
+ ---------------------------
procedure Check_Task_Activation (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
+ Inter_Procs : constant Elist_Id := New_Elmt_List;
+ Intra_Procs : constant Elist_Id := New_Elmt_List;
Ent : Entity_Id;
P : Entity_Id;
Task_Scope : Entity_Id;
Cunit_SC : Boolean := False;
Decl : Node_Id;
Elmt : Elmt_Id;
- Inter_Procs : Elist_Id := New_Elmt_List;
- Intra_Procs : Elist_Id := New_Elmt_List;
Enclosing : Entity_Id;
procedure Add_Task_Proc (Typ : Entity_Id);
and then Has_Task (Base_Type (Typ))
then
Comp := First_Component (Typ);
-
while Present (Comp) loop
Add_Task_Proc (Etype (Comp));
Comp := Next_Component (Comp);
-- Skip this test if errors have occurred, since in this case
-- we can get false indications.
- if Total_Errors_Detected /= 0 then
+ if Serious_Errors_Detected /= 0 then
return;
end if;
("task will be activated before elaboration of its body?",
Decl);
Error_Msg_N
- ("Program_Error will be raised at run-time?", Decl);
+ ("\Program_Error will be raised at run-time?", Decl);
elsif
Present (Corresponding_Body (Unit_Declaration_Node (Proc)))
end if;
else
- Elmt := First_Elmt (Inter_Procs);
-
- -- No need for multiple entries of the same type.
+ -- No need for multiple entries of the same type
+ Elmt := First_Elmt (Inter_Procs);
while Present (Elmt) loop
if Node (Elmt) = Proc then
return;
begin
if Present (Decls) then
Decl := First (Decls);
-
while Present (Decl) loop
-
if Nkind (Decl) = N_Object_Declaration
and then Has_Task (Etype (Defining_Identifier (Decl)))
then
----------------
function Outer_Unit (E : Entity_Id) return Entity_Id is
- Outer : Entity_Id := E;
+ Outer : Entity_Id;
begin
+ Outer := E;
while Present (Outer) loop
- if Suppress_Elaboration_Checks (Outer) then
+ if Elaboration_Checks_Suppressed (Outer) then
Cunit_SC := True;
end if;
begin
Enclosing := Outer_Unit (Current_Scope);
- -- Find all tasks declared in the current unit.
+ -- Find all tasks declared in the current unit
if Nkind (N) = N_Package_Body then
P := Unit_Declaration_Node (Corresponding_Spec (N));
-- 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
-- the task body to be elaborated before the current one.
Elmt := First_Elmt (Inter_Procs);
-
while Present (Elmt) loop
Ent := Node (Elmt);
Task_Scope := Outer_Unit (Scope (Ent));
if not Is_Compilation_Unit (Task_Scope) then
null;
- elsif Suppress_Elaboration_Warnings (Task_Scope) then
+ elsif Suppress_Elaboration_Warnings (Task_Scope)
+ or else Elaboration_Checks_Suppressed (Task_Scope)
+ then
null;
elsif Dynamic_Elaboration_Checks then
if not Elaboration_Checks_Suppressed (Ent)
and then not Cunit_SC
- and then not Restrictions (No_Entry_Calls_In_Elaboration_Code)
+ and then
+ not Restriction_Active (No_Entry_Calls_In_Elaboration_Code)
then
-- Runtime elaboration check required. generate check of the
-- elaboration Boolean for the unit containing the entity.
end if;
else
- -- Force the binder to elaborate other unit first.
+ -- Force the binder to elaborate other unit first
if not Suppress_Elaboration_Warnings (Ent)
+ and then not Elaboration_Checks_Suppressed (Ent)
and then Elab_Warnings
and then not Suppress_Elaboration_Warnings (Task_Scope)
+ and then not Elaboration_Checks_Suppressed (Task_Scope)
then
Error_Msg_Node_2 := Task_Scope;
Error_Msg_NE ("activation of an instance of task type&" &
" requires pragma Elaborate_All on &?", N, Ent);
end if;
- Set_Elaborate_All_Desirable (Task_Scope);
+ Activate_Elaborate_All_Desirable (N, Task_Scope);
Set_Suppress_Elaboration_Warnings (Task_Scope);
end if;
-- the task procedure bodies, which are available.
In_Task_Activation := True;
- Elmt := First_Elmt (Intra_Procs);
+ Elmt := First_Elmt (Intra_Procs);
while Present (Elmt) loop
Ent := Node (Elmt);
Check_Internal_Call_Continue (N, Ent, Enclosing, Ent);
In_Task_Activation := False;
end Check_Task_Activation;
+ --------------------------------
+ -- Set_Elaboration_Constraint --
+ --------------------------------
+
+ procedure Set_Elaboration_Constraint
+ (Call : Node_Id;
+ Subp : Entity_Id;
+ Scop : Entity_Id)
+ is
+ Elab_Unit : Entity_Id;
+ Init_Call : constant Boolean :=
+ Chars (Subp) = Name_Initialize
+ and then Comes_From_Source (Subp)
+ and then Present (Parameter_Associations (Call))
+ and then Is_Controlled (Etype (First_Actual (Call)));
+ begin
+ -- If the unit is mentioned in a with_clause of the current
+ -- unit, it is visible, and we can set the elaboration flag.
+
+ if Is_Immediately_Visible (Scop)
+ or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop))
+ then
+ Activate_Elaborate_All_Desirable (Call, Scop);
+ Set_Suppress_Elaboration_Warnings (Scop, True);
+ return;
+ end if;
+
+ -- If this is not an initialization call or a call using object notation
+ -- we know that the unit of the called entity is in the context, and
+ -- we can set the flag as well. The unit need not be visible if the call
+ -- occurs within an instantiation.
+
+ if Is_Init_Proc (Subp)
+ or else Init_Call
+ or else Nkind (Original_Node (Call)) = N_Selected_Component
+ then
+ null; -- detailed processing follows.
+
+ else
+ Activate_Elaborate_All_Desirable (Call, Scop);
+ Set_Suppress_Elaboration_Warnings (Scop, True);
+ return;
+ end if;
+
+ -- If the unit is not in the context, there must be an intermediate
+ -- unit that is, on which we need to place to elaboration flag. This
+ -- happens with init proc calls.
+
+ if Is_Init_Proc (Subp)
+ or else Init_Call
+ then
+ -- The initialization call is on an object whose type is not declared
+ -- in the same scope as the subprogram. The type of the object must
+ -- be a subtype of the type of operation. This object is the first
+ -- actual in the call.
+
+ declare
+ Typ : constant Entity_Id :=
+ Etype (First (Parameter_Associations (Call)));
+ begin
+ Elab_Unit := Scope (Typ);
+ while (Present (Elab_Unit))
+ and then not Is_Compilation_Unit (Elab_Unit)
+ loop
+ Elab_Unit := Scope (Elab_Unit);
+ end loop;
+ end;
+
+ -- If original node uses selected component notation, the prefix is
+ -- visible and determines the scope that must be elaborated. After
+ -- rewriting, the prefix is the first actual in the call.
+
+ elsif Nkind (Original_Node (Call)) = N_Selected_Component then
+ Elab_Unit := Scope (Etype (First (Parameter_Associations (Call))));
+
+ -- Not one of special cases above
+
+ else
+ -- Using previously computed scope. If the elaboration check is
+ -- done after analysis, the scope is not visible any longer, but
+ -- must still be in the context.
+
+ Elab_Unit := Scop;
+ end if;
+
+ Activate_Elaborate_All_Desirable (Call, Elab_Unit);
+ Set_Suppress_Elaboration_Warnings (Elab_Unit, True);
+ end Set_Elaboration_Constraint;
+
----------------------
-- Has_Generic_Body --
----------------------
-- Otherwise look and see if we are embedded in a further package
- elsif Is_Package (Scop) then
+ elsif Is_Package_Or_Generic_Package (Scop) then
-- If so, get the body of the enclosing package, and look in
-- its package body for the package body we are looking for.
-- Case of entity is in other than a package spec, in this case
-- the body, if present, must be in the same declarative part.
- if not Is_Package (Scop) then
+ if not Is_Package_Or_Generic_Package (Scop) then
declare
P : Node_Id;
begin
- P := Declaration_Node (Ent);
-
-- Declaration node may get us a spec, so if so, go to
-- the parent declaration.
+ P := Declaration_Node (Ent);
while not Is_List_Member (P) loop
P := Parent (P);
end loop;
-- Unfortunately this does not work if the call has a dynamic size,
-- because gigi regards it as a dynamic-sized temporary. If such a call
-- appears in a short-circuit expression, the elaboration check will be
- -- missed (rare enough ???).
+ -- missed (rare enough ???). Otherwise, the code below inserts the check
+ -- at the appropriate place before the call. Same applies in the even
+ -- rarer case the return type has a known size but is unconstrained.
else
if Nkind (N) = N_Function_Call
and then Analyzed (Parent (N))
and then Size_Known_At_Compile_Time (Etype (N))
+ and then
+ (not Has_Discriminants (Etype (N))
+ or else Is_Constrained (Etype (N)))
+
then
declare
Typ : constant Entity_Id := Etype (N);
if Is_Generic_Unit (Ent) then
Error_Msg_NE ("\?& instantiated #", N, Ent);
- elsif Chars (Ent) = Name_uInit_Proc then
+ elsif Is_Init_Proc (Ent) then
Error_Msg_N ("\?initialization procedure called #", N);
elsif Is_Printable_Error_Name (Chars (Ent)) then
----------------------------
function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean is
- S1 : Entity_Id := Scop1;
- S2 : Entity_Id := Scop2;
+ S1 : Entity_Id;
+ S2 : Entity_Id;
begin
+ -- Find elaboration scope for Scop1
+ -- This is either a subprogram or a compilation unit.
+
+ S1 := Scop1;
while S1 /= Standard_Standard
+ and then not Is_Compilation_Unit (S1)
and then (Ekind (S1) = E_Package
or else
+ Ekind (S1) = E_Protected_Type
+ or else
Ekind (S1) = E_Block)
loop
S1 := Scope (S1);
end loop;
+ -- Find elaboration scope for Scop2
+
+ S2 := Scop2;
while S2 /= Standard_Standard
+ and then not Is_Compilation_Unit (S2)
and then (Ekind (S2) = E_Package
or else
Ekind (S2) = E_Protected_Type
if Nkind (N) = N_Subprogram_Declaration then
declare
Ent : constant Entity_Id := Defining_Unit_Name (Specification (N));
-
begin
Set_Is_Imported (Ent);
Set_Convention (Ent, Convention_Stubbed);
elsif Nkind (N) = N_Package_Declaration then
declare
Spec : constant Node_Id := Specification (N);
-
begin
- New_Scope (Defining_Unit_Name (Spec));
+ Push_Scope (Defining_Unit_Name (Spec));
Supply_Bodies (Visible_Declarations (Spec));
Supply_Bodies (Private_Declarations (Spec));
Pop_Scope;
procedure Supply_Bodies (L : List_Id) is
Elmt : Node_Id;
-
begin
if Present (L) then
Elmt := First (L);
begin
Scop := E1;
-
loop
if Scop = E2 then
return True;
begin
Item := First (Context_Items (Cunit (Current_Sem_Unit)));
-
while Present (Item) loop
if Nkind (Item) = N_Pragma
and then Get_Pragma_Id (Chars (Item)) = Pragma_Elaborate_All
then
+ -- Return if some previous error on the pragma itself
+
+ if Error_Posted (Item) then
+ return False;
+ end if;
+
Elab_Id :=
- Entity (
- Expression (First (Pragma_Argument_Associations (Item))));
- Par := Parent (Unit_Declaration_Node (Elab_Id));
- Item2 := First (Context_Items (Par));
+ Entity
+ (Expression (First (Pragma_Argument_Associations (Item))));
+
+ Par := Parent (Unit_Declaration_Node (Elab_Id));
+ Item2 := First (Context_Items (Par));
while Present (Item2) loop
if Nkind (Item2) = N_With_Clause
and then Entity (Name (Item2)) = E
OSDN Git Service
