-- --
-- B o d y --
-- --
--- Copyright (C) 1997-2010, Free Software Foundation, Inc. --
+-- Copyright (C) 1997-2012, 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 Restrict; use Restrict;
with Rident; use Rident;
with Sem; use Sem;
+with Sem_Aux; use Sem_Aux;
with Sem_Cat; use Sem_Cat;
with Sem_Ch7; use Sem_Ch7;
with Sem_Ch8; use Sem_Ch8;
with Stand; use Stand;
with Table;
with Tbuild; use Tbuild;
+with Uintp; use Uintp;
with Uname; use Uname;
package body Sem_Elab is
E : Entity_Id;
Outer_Scope : Entity_Id;
Inter_Unit_Only : Boolean;
- Generate_Warnings : Boolean := True);
- -- This is the internal recursive routine that is called to check for a
+ Generate_Warnings : Boolean := True;
+ In_Init_Proc : Boolean := False);
+ -- This is the internal recursive routine that is called to check for
-- possible elaboration error. The argument N is a subprogram call or
- -- generic instantiation to be checked, and E is the entity of the called
- -- subprogram, or instantiated generic unit. The flag Outer_Scope is the
- -- outer level scope for the original call. Inter_Unit_Only is set if the
- -- call is only to be checked in the case where it is to another unit (and
- -- skipped if within a unit). Generate_Warnings is set to False to suppress
- -- warning messages about missing pragma Elaborate_All's. These messages
- -- are not wanted for inner calls in the dynamic model.
+ -- generic instantiation, or 'Access attribute reference to be checked, and
+ -- E is the entity of the called subprogram, or instantiated generic unit,
+ -- or subprogram referenced by 'Access.
+ --
+ -- The flag Outer_Scope is the outer level scope for the original call.
+ -- Inter_Unit_Only is set if the call is only to be checked in the
+ -- case where it is to another unit (and skipped if within a unit).
+ -- Generate_Warnings is set to False to suppress warning messages about
+ -- missing pragma Elaborate_All's. These messages are not wanted for
+ -- inner calls in the dynamic model. Note that an instance of the Access
+ -- attribute applied to a subprogram also generates a call to this
+ -- procedure (since the referenced subprogram may be called later
+ -- indirectly). Flag In_Init_Proc should be set whenever the current
+ -- context is a type init proc.
procedure Check_Bad_Instantiation (N : Node_Id);
-- N is a node for an instantiation (if called with any other node kind,
-- 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
-- or instantiation node for which the check code is required. C is the
-- test whose failure triggers the raise.
+ function Is_Finalization_Procedure (Id : Entity_Id) return Boolean;
+ -- Determine whether entity Id denotes a [Deep_]Finalize procedure
+
procedure Output_Calls (N : Node_Id);
-- Outputs chain of calls stored in the Elab_Call table. The caller has
-- already generated the main warning message, so the warnings generated
-- On entry C_Scope is set to some scope. On return, C_Scope is reset
-- to be the enclosing compilation unit of this scope.
+ function Get_Referenced_Ent (N : Node_Id) return Entity_Id;
+ -- N is either a function or procedure call or an access attribute that
+ -- references a subprogram. This call retrieves the relevant 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 Empty is
+ -- returned. This happens with non-analyzed calls in nested generics.
+
+ 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 Spec_Entity (E : Entity_Id) return Entity_Id;
-- Given a compilation unit entity, if it is a spec entity, it is returned
-- unchanged. If it is a body entity, then the spec for the corresponding
E : Entity_Id;
Outer_Scope : Entity_Id;
Inter_Unit_Only : Boolean;
- Generate_Warnings : Boolean := True)
+ Generate_Warnings : Boolean := True;
+ In_Init_Proc : Boolean := False)
is
Loc : constant Source_Ptr := Sloc (N);
Ent : Entity_Id;
Inst_Case : constant Boolean := Nkind (N) in N_Generic_Instantiation;
-- Indicates if we have instantiation case
+ Access_Case : constant Boolean := Nkind (N) = N_Attribute_Reference;
+ -- Indicates if we have Access attribute case
+
Caller_Unit_Internal : Boolean;
Callee_Unit_Internal : Boolean;
-- 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)
+ if Nkind (N) in N_Subprogram_Call
and then No_Elaboration_Check (N)
then
return;
if Body_Acts_As_Spec then
if Is_TSS (Ent, TSS_Deep_Initialize) then
declare
- Typ : Entity_Id;
+ Typ : constant Entity_Id := Etype (First_Formal (Ent));
Init : Entity_Id;
- begin
- Typ := Etype (Next_Formal (First_Formal (Ent)));
+ begin
if not Is_Controlled (Typ) then
return;
else
Is_Internal_File_Name
(Unit_File_Name (Get_Source_Unit (E_Scope)));
- -- Do not give a warning if the with'ed unit is internal
- -- and this is the generic instantiation case (this saves a
- -- lot of hassle dealing with the Text_IO special child units)
+ -- Do not give a warning if the with'ed unit is internal and this is
+ -- the generic instantiation case (this saves a lot of hassle dealing
+ -- with the Text_IO special child units)
if Callee_Unit_Internal and Inst_Case then
return;
(Unit_File_Name (Get_Source_Unit (C_Scope)));
end if;
- -- Do not give a warning if the with'ed unit is internal
- -- and the caller is not internal (since the binder always
- -- elaborates internal units first).
+ -- Do not give a warning if the with'ed unit is internal and the
+ -- caller is not internal (since the binder always elaborates
+ -- internal units first).
if Callee_Unit_Internal and (not Caller_Unit_Internal) then
return;
end if;
-- If the call is in an instance, and the called entity is not
- -- defined in the same instance, then the elaboration issue
- -- focuses around the unit containing the template, it is
- -- this unit which requires an Elaborate_All.
+ -- defined in the same instance, then the elaboration issue focuses
+ -- around the unit containing the template, it is this unit which
+ -- requires an Elaborate_All.
- -- However, if we are doing dynamic elaboration, we need to
- -- chase the call in the usual manner.
+ -- However, if we are doing dynamic elaboration, we need to chase the
+ -- call in the usual manner.
- -- We do not handle the case of calling a generic formal correctly
- -- in the static case. See test 4703-004 to explore this gap ???
+ -- We do not handle the case of calling a generic formal correctly in
+ -- the static case.???
Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N)));
Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent)));
-- 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;
+ declare
+ Ent : constant Entity_Id := Get_Referenced_Ent (N);
+ begin
+ if Is_Init_Proc (Ent)
+ and then not In_Same_Extended_Unit (N, Ent)
+ then
+ W_Scope := Scope (Ent);
+ else
+ W_Scope := E;
+ end if;
+ end;
+
+ -- Now loop through scopes to get to the enclosing compilation unit
while not Is_Compilation_Unit (W_Scope) loop
W_Scope := Scope (W_Scope);
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.
+ -- Msg_D is suppressed for the attribute reference case, since
+ -- we never raise Program_Error for an attribute reference.
------------------
-- Elab_Warning --
is
begin
if Dynamic_Elaboration_Checks then
- Error_Msg_NE (Msg_D, N, Ent);
+ if not Access_Case then
+ Error_Msg_NE (Msg_D, N, Ent);
+ end if;
else
Error_Msg_NE (Msg_S, N, Ent);
end if;
-- Start of processing for Generate_Elab_Warnings
begin
+ -- Instantiation case
+
if Inst_Case then
Elab_Warning
("instantiation of& may raise Program_Error?",
"info: instantiation of& during elaboration?", Ent);
+ -- Indirect call case, warning only in static elaboration
+ -- case, because the attribute reference itself cannot raise
+ -- an exception.
+
+ elsif Access_Case then
+ Elab_Warning
+ ("", "info: access to& during elaboration?", Ent);
+
+ -- Subprogram call case
+
else
if Nkind (Name (N)) in N_Has_Entity
and then Is_Init_Proc (Entity (Name (N)))
("\missing pragma Elaborate for&?",
"\info: implicit pragma Elaborate for& generated?",
W_Scope);
+
else
Elab_Warning
("\missing pragma Elaborate_All for&?",
Insert_Elab_Check (N,
Make_Attribute_Reference (Loc,
Attribute_Name => Name_Elaborated,
- Prefix => New_Occurrence_Of (Spec_Entity (E_Scope), Loc)));
+ Prefix =>
+ New_Occurrence_Of (Spec_Entity (E_Scope), Loc)));
+
+ -- Prevent duplicate elaboration checks on the same call,
+ -- which can happen if the body enclosing the call appears
+ -- itself in a call whose elaboration check is delayed.
+
+ if Nkind (N) in N_Subprogram_Call then
+ Set_No_Elaboration_Check (N);
+ end if;
end if;
-- Case of static elaboration model
then
null;
+ -- Do not generate an Elaborate_All for finalization routines
+ -- which perform partial clean up as part of initialization.
+
+ elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then
+ null;
+
-- Here we need to generate an implicit elaborate all
else
---------------------
procedure Check_Elab_Call
- (N : Node_Id;
- Outer_Scope : Entity_Id := Empty)
+ (N : Node_Id;
+ Outer_Scope : Entity_Id := Empty;
+ In_Init_Proc : Boolean := False)
is
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
then
Check_Restriction (No_Entry_Calls_In_Elaboration_Code, N);
- -- Nothing to do if this is not a call (happens in some error
- -- conditions, and in some cases where rewriting occurs).
+ -- Nothing to do if this is not a call or attribute reference (happens
+ -- in some error conditions, and in some cases where rewriting occurs).
- elsif Nkind (N) /= N_Function_Call
- and then Nkind (N) /= N_Procedure_Call_Statement
+ elsif Nkind (N) not in N_Subprogram_Call
+ and then Nkind (N) /= N_Attribute_Reference
then
return;
if Comes_From_Source (N)
and then In_Preelaborated_Unit
and then not In_Inlined_Body
+ and then Nkind (N) /= N_Attribute_Reference
then
-- This is a warning in GNAT mode allowing such calls to be
-- used in the predefined library with appropriate care.
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.
+ -- We provide a debug flag to disable this check. 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;
-- but we need to capture local suppress pragmas
-- that may inhibit checks on this call.
- Ent := Get_Called_Ent;
+ Ent := Get_Referenced_Ent (N);
if No (Ent) then
return;
end if;
end if;
- Ent := Get_Called_Ent;
+ Ent := Get_Referenced_Ent (N);
if No (Ent) then
return;
C_Scope := Current_Scope;
- -- If not outer level call, then we follow it if it is within
- -- the original scope of the outer call.
+ -- If not outer level call, then we follow it if it is within the
+ -- original scope of the outer call.
if Present (Outer_Scope)
and then Within (Scope (Ent), Outer_Scope)
then
Set_C_Scope;
- Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False);
+ Check_A_Call
+ (N => N,
+ E => Ent,
+ Outer_Scope => Outer_Scope,
+ Inter_Unit_Only => False,
+ In_Init_Proc => In_Init_Proc);
elsif Elaboration_Checks_Suppressed (Current_Scope) then
null;
(N,
Ent,
Standard_Standard,
- Inter_Unit_Only => True,
+ Inter_Unit_Only => True,
Generate_Warnings => False);
-- Otherwise nothing to do
Func : Entity_Id;
begin
- if (Nkind (Nod) = N_Function_Call
- or else Nkind (Nod) = N_Procedure_Call_Statement)
+ if Nkind (Nod) in N_Subprogram_Call
and then Is_Entity_Name (Name (Nod))
then
Func := Entity (Name (Nod));
-- arguments that are assignments (OUT or IN OUT mode formals).
elsif Nkind (N) = N_Procedure_Call_Statement then
- Check_Elab_Call (N, Outer_Scope);
+ Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E));
Actual := First_Actual (N);
while Present (Actual) loop
return OK;
+ -- If we have an access attribute for a subprogram, check
+ -- it. Suppress this behavior under debug flag.
+
+ elsif not Debug_Flag_Dot_UU
+ and then Nkind (N) = N_Attribute_Reference
+ and then (Attribute_Name (N) = Name_Access
+ or else
+ Attribute_Name (N) = Name_Unrestricted_Access)
+ and then Is_Entity_Name (Prefix (N))
+ and then Is_Subprogram (Entity (Prefix (N)))
+ then
+ Check_Elab_Call (N, Outer_Scope);
+ return OK;
+
-- If we have a generic instantiation, check it
elsif Nkind (N) in N_Generic_Instantiation then
end if;
-- Here is the case of calling a subprogram where the body has not yet
- -- been encountered, a warning message is needed.
+ -- been encountered. A warning message is needed, except if this is the
+ -- case of appearing within an aspect specification that results in
+ -- a check call, we do not really have such a situation, so no warning
+ -- is needed (e.g. the case of a precondition, where the call appears
+ -- textually before the body, but in actual fact is moved to the
+ -- appropriate subprogram body and so does not need a check).
+
+ declare
+ P : Node_Id;
+ begin
+ P := Parent (N);
+ loop
+ if Nkind (P) in N_Subexpr then
+ P := Parent (P);
+ elsif Nkind (P) = N_If_Statement
+ and then Nkind (Original_Node (P)) = N_Pragma
+ and then Present (Corresponding_Aspect (Original_Node (P)))
+ then
+ return;
+ else
+ exit;
+ end if;
+ end loop;
+ end;
+
+ -- Not that special case, warning and dynamic check is required
-- If we have nothing in the call stack, then this is at the outer
-- level, and the ABE is bound to occur.
Insert_Action (Declaration_Node (E),
Make_Object_Declaration (Loce,
Defining_Identifier => Ent,
- Object_Definition =>
- New_Occurrence_Of (Standard_Boolean, Loce),
- Expression => New_Occurrence_Of (Standard_False, Loce)));
+ Object_Definition =>
+ New_Occurrence_Of (Standard_Short_Integer, Loce),
+ Expression =>
+ Make_Integer_Literal (Loc, Uint_0)));
-- Set elaboration flag at the point of the body
end;
end if;
- -- Generate check of the elaboration Boolean
+ -- Generate check of the elaboration counter
Insert_Elab_Check (N,
- New_Occurrence_Of (Elaboration_Entity (E), Loc));
+ Make_Attribute_Reference (Loc,
+ Attribute_Name => Name_Elaborated,
+ Prefix => New_Occurrence_Of (E, Loc)));
end if;
-- Generate the warning
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.
+ -- elaboration counter for the unit containing the entity.
Insert_Elab_Check (N,
Make_Attribute_Reference (Loc,
Set_Suppress_Elaboration_Warnings (Elab_Unit, True);
end Set_Elaboration_Constraint;
+ ------------------------
+ -- Get_Referenced_Ent --
+ ------------------------
+
+ function Get_Referenced_Ent (N : Node_Id) return Entity_Id is
+ Nam : Node_Id;
+
+ begin
+ if Nkind (N) = N_Attribute_Reference then
+ Nam := Prefix (N);
+ else
+ Nam := Name (N);
+ end if;
+
+ 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_Referenced_Ent;
+
----------------------
-- Has_Generic_Body --
----------------------
end if;
end Insert_Elab_Check;
+ -------------------------------
+ -- Is_Finalization_Procedure --
+ -------------------------------
+
+ function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is
+ begin
+ -- Check whether Id is a procedure with at least one parameter
+
+ if Ekind (Id) = E_Procedure
+ and then Present (First_Formal (Id))
+ then
+ declare
+ Typ : constant Entity_Id := Etype (First_Formal (Id));
+ Deep_Fin : Entity_Id := Empty;
+ Fin : Entity_Id := Empty;
+
+ begin
+ -- If the type of the first formal does not require finalization
+ -- actions, then this is definitely not [Deep_]Finalize.
+
+ if not Needs_Finalization (Typ) then
+ return False;
+ end if;
+
+ -- At this point we have the following scenario:
+
+ -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]);
+
+ -- Recover the two possible versions of [Deep_]Finalize using the
+ -- type of the first parameter and compare with the input.
+
+ Deep_Fin := TSS (Typ, TSS_Deep_Finalize);
+
+ if Is_Controlled (Typ) then
+ Fin := Find_Prim_Op (Typ, Name_Finalize);
+ end if;
+
+ return
+ (Present (Deep_Fin) and then Id = Deep_Fin)
+ or else
+ (Present (Fin) and then Id = Fin);
+ end;
+ end if;
+
+ return False;
+ end Is_Finalization_Procedure;
+
------------------
-- Output_Calls --
------------------
git://gcc.gnu.org / gcc.git / blobdiff