-- --
-- B o d y --
-- --
--- --
--- Copyright (C) 1997-2002 Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2004 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- --
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;
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, thus W_Scope is always in a visible unit. This is
+ -- the scope for the Elaborate_All if one is needed.
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;
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;
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 initialization procedures, where the init proc is in the root
+ -- package, where we start fromn the entity of the name in the call.
+
+ if Is_Entity_Name (Name (N))
+ and then Is_Init_Proc (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;
-
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);
- if Unit_Callee = No_Unit
- and then E_Scope = Current_Scope
+ else
+ if Is_Init_Proc (Entity (Name (N)))
+ and then Comes_From_Source (Ent)
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.
-
- E_Scope := Ent;
+ Error_Msg_NE
+ ("implicit call to & may raise Program_Error?", N, Ent);
- while not Is_Compilation_Unit (E_Scope) loop
- E_Scope := Scope (E_Scope);
- end loop;
+ else
+ Error_Msg_NE
+ ("call to & may raise Program_Error?", N, Ent);
end if;
end if;
Error_Msg_Qual_Level := Nat'Last;
Error_Msg_NE
- ("\missing pragma Elaborate_All for&?", N, E_Scope);
+ ("\missing pragma Elaborate_All for&?", N, W_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.
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
+
+ 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_Elaborate_All_Desirable (E_Scope);
- Set_Suppress_Elaboration_Warnings (E_Scope);
+ Set_Elaborate_All_Desirable (W_Scope);
+ Set_Suppress_Elaboration_Warnings (W_Scope, True);
+ 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
(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
-- For an entry call, check relevant restriction
-- 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).
+ -- 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
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.
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 Process (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
+ 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 Process;
+
+ procedure Traverse_Body is new Traverse_Proc (Process);
+
+ -- 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;
----------------------
-- 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;
(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);
Ent := Get_Generic_Entity (N);
From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit;
-- Checks for call that needs checking, and if so checks
-- it. Always returns OK, so entire tree is traversed.
+ -------------
+ -- Process --
+ -------------
+
function Process (N : Node_Id) return Traverse_Result is
begin
-- If user has specified that there are no entry calls in elaboration
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;
-- 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);
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_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);
-- 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;
begin
while Present (Outer) loop
- if Suppress_Elaboration_Checks (Outer) then
+ if Elaboration_Checks_Suppressed (Outer) then
Cunit_SC := True;
end if;
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&" &
-- 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
if Nkind (Item) = N_Pragma
and then Get_Pragma_Id (Chars (Item)) = Pragma_Elaborate_All
then
+ if Error_Posted (Item) then
+
+ -- Some previous error on the pragma itself
+
+ 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));
OSDN Git Service
