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);
+ Generate_Warnings : Boolean := True;
+ In_Init_Proc : Boolean := False);
-- This is the internal recursive routine that is called to check for a
-- possible elaboration error. The argument N is a subprogram call or
-- generic instantiation to be checked, and E is the entity of the called
-- 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.
+ -- are not wanted for inner calls in the dynamic model. 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.
+ 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;
declare
Typ : constant Entity_Id := Etype (First_Formal (Ent));
Init : Entity_Id;
+
begin
if not Is_Controlled (Typ) then
return;
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;
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
-- 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
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,
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 --
------------------
OSDN Git Service
