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

[Ada] Implement late initialization rules for type extensions 

Default initialization of a record object is required to initialize any
components that "require late initialization" after other components.
This includes the case of a type extension; "late initialization"
components of the parent type are required to be initialized after
non-late-init extension components. This is implemented by generalizing
the use of an existing init proc parameter. Previously, the init proc
for a tagged type took a Boolean parameter indicating whether or not to
initialize the Tag component. With this change, this parameter can now
take on any of four values indicating whether to perform

   1) Full initialization (including the tag component).
   2) Full initialization except for the tag component.
   3) Early (non-tag) initialization only.
   4) Late (non-tag) initialization only.

With this change, the init proc for a type extension has the option of
performing the early and late portions of the parent's initialization
via two separate calls to the parent type's init proc.

gcc/ada/

	* exp_ch3.ads (Build_Intialization_Call): Add new formal
	parameter, Init_Control_Actual, with default value. Clients
	outside of package Exp_Ch3 are unaffected.
	* exp_ch3.adb (Initialization_Control): new package; support for
	this 4-valued parameter.  The existing Requires_Late_Init
	function is moved into this new package.
	(Build_Initialization_Call): Add new formal parameter for
	subprogram body, use this new formal parameter in generating an
	init proc call.
	(Build_Record_Init_Proc): Replace Set_Tag Boolean formal
	parameter with 4-valued Init_Control_Formal. Wrap if-statements
	with appropriate conditions around tag initialization, early
	initialization, and late initialization statements.
	* exp_util.adb (Build_Task_Image_Decl): Avoid problem with
	duplicate declarations when an init proc for a type extension
	calls the parent type's init proc twice.
This commit is contained in:
Steve Baird 2022-02-08 17:43:14 -08:00 committed by Pierre-Marie de Rodat
parent 7b6fa643ef
commit b77029ff25
3 changed files with 530 additions and 245 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

743
gcc/ada/exp_ch3.adb
View File

@ -184,6 +184,63 @@ package body Exp_Ch3 is
-- Treat user-defined stream operations as renaming_as_body if the
-- subprogram they rename is not frozen when the type is frozen.
package Initialization_Control is
function Requires_Late_Init
(Decl : Node_Id; Rec_Type : Entity_Id) return Boolean;
-- Return True iff the given component declaration requires late
-- initialization, as defined by 3.3.1 (8.1/5).
function Has_Late_Init_Component
(Tagged_Rec_Type : Entity_Id) return Boolean;
-- Return True iff the given tagged record type has at least one
-- component that requires late initialization; this includes
-- components of ancestor types.
type Initialization_Mode is
(Full_Init, Full_Init_Except_Tag, Early_Init_Only, Late_Init_Only);
-- The initialization routine for a tagged type is passed in a
-- formal parameter of this type, indicating what initialization
-- is to be performed. This parameter defaults to Full_Init in all
-- cases except when the init proc of a type extension (let's call
-- that type T2) calls the init proc of its parent (let's call that
-- type T1). In that case, one of the other 3 values will
-- be passed in. In all three of those cases, the Tag component has
-- already been initialized before the call and is therefore not to be
-- modified. T2's init proc will either call T1's init proc
-- once (with Full_Init_Except_Tag as the parameter value) or twice
-- (first with Early_Init_Only, then later with Late_Init_Only),
-- depending on the result returned by Has_Late_Init_Component (T1).
-- In the latter case, the first call does not initialize any
-- components that require late initialization and the second call
-- then performs that deferred initialization.
-- Strictly speaking, the formal parameter subtype is actually Natural
-- but calls will only pass in values corresponding to literals
-- of this enumeration type.
function Make_Mode_Literal
(Loc : Source_Ptr; Mode : Initialization_Mode) return Node_Id
is (Make_Integer_Literal (Loc, Initialization_Mode'Pos (Mode)));
-- Generate an integer literal for a given mode value.
function Tag_Init_Condition
(Loc : Source_Ptr;
Init_Control_Formal : Entity_Id) return Node_Id;
function Early_Init_Condition
(Loc : Source_Ptr;
Init_Control_Formal : Entity_Id) return Node_Id;
function Late_Init_Condition
(Loc : Source_Ptr;
Init_Control_Formal : Entity_Id) return Node_Id;
-- These three functions each return a Boolean expression that
-- can be used to determine whether a given call to the initialization
-- expression for a tagged type should initialize (respectively)
-- the Tag component, the non-Tag components that do not require late
-- initialization, and the components that do require late
-- initialization.
end Initialization_Control;
procedure Initialization_Warning (E : Entity_Id);
-- If static elaboration of the package is requested, indicate
-- when a type does meet the conditions for static initialization. If
@ -1447,14 +1504,15 @@ package body Exp_Ch3 is
-- end;
function Build_Initialization_Call
(Loc : Source_Ptr;
Id_Ref : Node_Id;
Typ : Entity_Id;
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List;
With_Default_Init : Boolean := False;
Constructor_Ref : Node_Id := Empty) return List_Id
(Loc : Source_Ptr;
Id_Ref : Node_Id;
Typ : Entity_Id;
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List;
With_Default_Init : Boolean := False;
Constructor_Ref : Node_Id := Empty;
Init_Control_Actual : Entity_Id := Empty) return List_Id
is
Res : constant List_Id := New_List;
@ -1838,14 +1896,26 @@ package body Exp_Ch3 is
-- If this is a call to initialize the parent component of a derived
-- tagged type, indicate that the tag should not be set in the parent.
-- This is done via the actual parameter value for the Init_Control
-- formal parameter, which is also used to deal with late initialization
-- requirements.
--
-- We pass in Full_Init_Except_Tag unless the caller tells us to do
-- otherwise (by passing in a nonempty Init_Control_Actual parameter).
if Is_Tagged_Type (Full_Init_Type)
and then not Is_CPP_Class (Full_Init_Type)
and then Nkind (Id_Ref) = N_Selected_Component
and then Chars (Selector_Name (Id_Ref)) = Name_uParent
then
Append_To (Args, New_Occurrence_Of (Standard_False, Loc));
declare
use Initialization_Control;
begin
Append_To (Args,
(if Present (Init_Control_Actual)
then Init_Control_Actual
else Make_Mode_Literal (Loc, Full_Init_Except_Tag)));
end;
elsif Present (Constructor_Ref) then
Append_List_To (Args,
New_Copy_List (Parameter_Associations (Constructor_Ref)));
@ -1906,8 +1976,9 @@ package body Exp_Ch3 is
Counter : Nat := 0;
Proc_Id : Entity_Id;
Rec_Type : Entity_Id;
Set_Tag : Entity_Id := Empty;
Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements
Init_Control_Formal : Entity_Id := Empty; -- set in Build_Init_Statements
Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements
function Build_Assignment
(Id : Entity_Id;
@ -2532,6 +2603,7 @@ package body Exp_Ch3 is
Proc_Spec_Node : Node_Id;
Record_Extension_Node : Node_Id;
use Initialization_Control;
begin
Body_Stmts := New_List;
Body_Node := New_Node (N_Subprogram_Body, Loc);
@ -2544,21 +2616,27 @@ package body Exp_Ch3 is
Append_List_To (Parameters,
Build_Discriminant_Formals (Rec_Type, True));
-- For tagged types, we add a flag to indicate whether the routine
-- is called to initialize a parent component in the init_proc of
-- a type extension. If the flag is false, we do not set the tag
-- because it has been set already in the extension.
-- For tagged types, we add a parameter to indicate what
-- portion of the object's initialization is to be performed.
-- This is used for two purposes:
-- 1) When a type extension's initialization procedure calls
-- the initialization procedure of the parent type, we do
-- not want the parent to initialize the Tag component;
-- it has been set already.
-- 2) If an ancestor type has at least one component that requires
-- late initialization, then we need to be able to initialize
-- those components separately after initializing any other
-- components.
if Is_Tagged_Type (Rec_Type) then
Set_Tag := Make_Temporary (Loc, 'P');
Init_Control_Formal := Make_Temporary (Loc, 'P');
Append_To (Parameters,
Make_Parameter_Specification (Loc,
Defining_Identifier => Set_Tag,
Defining_Identifier => Init_Control_Formal,
Parameter_Type =>
New_Occurrence_Of (Standard_Boolean, Loc),
Expression =>
New_Occurrence_Of (Standard_True, Loc)));
New_Occurrence_Of (Standard_Natural, Loc),
Expression => Make_Mode_Literal (Loc, Full_Init)));
end if;
-- Create an extra accessibility parameter to capture the level of
@ -2622,22 +2700,45 @@ package body Exp_Ch3 is
declare
Parent_IP : constant Name_Id :=
Make_Init_Proc_Name (Etype (Rec_Ent));
Stmt : Node_Id;
IP_Call : Node_Id;
IP_Stmts : List_Id;
Stmt : Node_Id := First (Stmts);
IP_Call : Node_Id := Empty;
begin
-- Look for a call to the parent IP at the beginning
-- of Stmts associated with the record extension
-- Look for a call to the parent IP associated with
-- the record extension.
-- The call will be inside not one but two
-- if-statements (with the same condition). Testing
-- the same Early_Init condition twice might seem
-- redundant. However, as soon as we exit this loop,
-- we are going to hoist the inner if-statement out
-- of the outer one; the "redundant" test was built
-- in anticipation of this hoisting.
Stmt := First (Stmts);
IP_Call := Empty;
while Present (Stmt) loop
if Nkind (Stmt) = N_Procedure_Call_Statement
and then Chars (Name (Stmt)) = Parent_IP
then
IP_Call := Stmt;
exit;
if Nkind (Stmt) = N_If_Statement then
declare
Then_Stmt1 : Node_Id :=
First (Then_Statements (Stmt));
Then_Stmt2 : Node_Id;
begin
while Present (Then_Stmt1) loop
if Nkind (Then_Stmt1) = N_If_Statement then
Then_Stmt2 :=
First (Then_Statements (Then_Stmt1));
if Nkind (Then_Stmt2) =
N_Procedure_Call_Statement
and then Chars (Name (Then_Stmt2)) =
Parent_IP
then
-- IP_Call is a call wrapped in an
-- if statement.
IP_Call := Then_Stmt1;
exit;
end if;
end if;
Next (Then_Stmt1);
end loop;
end;
end if;
Next (Stmt);
@ -2647,14 +2748,8 @@ package body Exp_Ch3 is
-- statements of this IP routine
if Present (IP_Call) then
IP_Stmts := New_List;
loop
Stmt := Remove_Head (Stmts);
Append_To (IP_Stmts, Stmt);
exit when Stmt = IP_Call;
end loop;
Prepend_List_To (Body_Stmts, IP_Stmts);
Remove (IP_Call);
Prepend_List_To (Body_Stmts, New_List (IP_Call));
end if;
end;
end if;
@ -2729,7 +2824,8 @@ package body Exp_Ch3 is
Elab_List := New_List (
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Condition =>
Tag_Init_Condition (Loc, Init_Control_Formal),
Then_Statements => Init_Tags_List));
if Elab_Flag_Needed (Rec_Type) then
@ -2755,7 +2851,8 @@ package body Exp_Ch3 is
else
Prepend_To (Body_Stmts,
Make_If_Statement (Loc,
Condition => New_Occurrence_Of (Set_Tag, Loc),
Condition =>
Tag_Init_Condition (Loc, Init_Control_Formal),
Then_Statements => Init_Tags_List));
end if;
@ -2823,11 +2920,18 @@ package body Exp_Ch3 is
begin
-- Search for the call to the IP of the parent. We assume
-- that the first init_proc call is for the parent.
-- It is wrapped in an "if Early_Init_Condition"
-- if-statement.
Ins_Nod := First (Body_Stmts);
while Present (Next (Ins_Nod))
and then (Nkind (Ins_Nod) /= N_Procedure_Call_Statement
or else not Is_Init_Proc (Name (Ins_Nod)))
and then
(Nkind (Ins_Nod) /= N_If_Statement
or else (Nkind (First (Then_Statements (Ins_Nod)))
/= N_Procedure_Call_Statement)
or else not Is_Init_Proc
(Name (First (Then_Statements
(Ins_Nod)))))
loop
Next (Ins_Nod);
end loop;
@ -2974,34 +3078,31 @@ package body Exp_Ch3 is
Decl : Node_Id;
Id : Entity_Id;
Parent_Stmts : List_Id;
Stmts : List_Id;
Parent_Id : Entity_Id := Empty;
Stmts, Late_Stmts : List_Id := Empty_List;
Typ : Entity_Id;
procedure Increment_Counter (Loc : Source_Ptr);
procedure Increment_Counter
(Loc : Source_Ptr; Late : Boolean := False);
-- Generate an "increment by one" statement for the current counter
-- and append it to the list Stmts.
-- and append it to the appropriate statement list.
procedure Make_Counter (Loc : Source_Ptr);
-- Create a new counter for the current component list. The routine
-- creates a new defining Id, adds an object declaration and sets
-- the Id generator for the next variant.
function Requires_Late_Initialization
(Decl : Node_Id;
Rec_Type : Entity_Id) return Boolean;
-- Return whether the given Decl requires late initialization, as
-- defined by 3.3.1 (8.1/5).
-----------------------
-- Increment_Counter --
-----------------------
procedure Increment_Counter (Loc : Source_Ptr) is
procedure Increment_Counter
(Loc : Source_Ptr; Late : Boolean := False) is
begin
-- Generate:
-- Counter := Counter + 1;
Append_To (Stmts,
Append_To ((if Late then Late_Stmts else Stmts),
Make_Assignment_Statement (Loc,
Name => New_Occurrence_Of (Counter_Id, Loc),
Expression =>
@ -3038,157 +3139,6 @@ package body Exp_Ch3 is
Make_Integer_Literal (Loc, 0)));
end Make_Counter;
----------------------------------
-- Requires_Late_Initialization --
----------------------------------
function Requires_Late_Initialization
(Decl : Node_Id;
Rec_Type : Entity_Id) return Boolean
is
References_Current_Instance : Boolean := False;
Has_Access_Discriminant : Boolean := False;
Has_Internal_Call : Boolean := False;
function Find_Access_Discriminant
(N : Node_Id) return Traverse_Result;
-- Look for a name denoting an access discriminant
function Find_Current_Instance
(N : Node_Id) return Traverse_Result;
-- Look for a reference to the current instance of the type
function Find_Internal_Call
(N : Node_Id) return Traverse_Result;
-- Look for an internal protected function call
------------------------------
-- Find_Access_Discriminant --
------------------------------
function Find_Access_Discriminant
(N : Node_Id) return Traverse_Result is
begin
if Is_Entity_Name (N)
and then Denotes_Discriminant (N)
and then Is_Access_Type (Etype (N))
then
Has_Access_Discriminant := True;
return Abandon;
else
return OK;
end if;
end Find_Access_Discriminant;
---------------------------
-- Find_Current_Instance --
---------------------------
function Find_Current_Instance
(N : Node_Id) return Traverse_Result is
begin
if Is_Entity_Name (N)
and then Present (Entity (N))
and then Is_Current_Instance (N)
then
References_Current_Instance := True;
return Abandon;
else
return OK;
end if;
end Find_Current_Instance;
------------------------
-- Find_Internal_Call --
------------------------
function Find_Internal_Call (N : Node_Id) return Traverse_Result is
function Call_Scope (N : Node_Id) return Entity_Id;
-- Return the scope enclosing a given call node N
----------------
-- Call_Scope --
----------------
function Call_Scope (N : Node_Id) return Entity_Id is
Nam : constant Node_Id := Name (N);
begin
if Nkind (Nam) = N_Selected_Component then
return Scope (Entity (Prefix (Nam)));
else
return Scope (Entity (Nam));
end if;
end Call_Scope;
begin
if Nkind (N) = N_Function_Call
and then Call_Scope (N)
= Corresponding_Concurrent_Type (Rec_Type)
then
Has_Internal_Call := True;
return Abandon;
else
return OK;
end if;
end Find_Internal_Call;
procedure Search_Access_Discriminant is new
Traverse_Proc (Find_Access_Discriminant);
procedure Search_Current_Instance is new
Traverse_Proc (Find_Current_Instance);
procedure Search_Internal_Call is new
Traverse_Proc (Find_Internal_Call);
begin
-- A component of an object is said to require late initialization
-- if:
-- it has an access discriminant value constrained by a per-object
-- expression;
if Has_Access_Constraint (Defining_Identifier (Decl))
and then No (Expression (Decl))
then
return True;
elsif Present (Expression (Decl)) then
-- it has an initialization expression that includes a name
-- denoting an access discriminant;
Search_Access_Discriminant (Expression (Decl));
if Has_Access_Discriminant then
return True;
end if;
-- or it has an initialization expression that includes a
-- reference to the current instance of the type either by
-- name...
Search_Current_Instance (Expression (Decl));
if References_Current_Instance then
return True;
end if;
-- ...or implicitly as the target object of a call.
if Is_Protected_Record_Type (Rec_Type) then
Search_Internal_Call (Expression (Decl));
if Has_Internal_Call then
return True;
end if;
end if;
end if;
return False;
end Requires_Late_Initialization;
-- Start of processing for Build_Init_Statements
begin
@ -3256,7 +3206,10 @@ package body Exp_Ch3 is
-- Leave any processing of component requiring late initialization
-- for the second pass.
if Requires_Late_Initialization (Decl, Rec_Type) then
if Initialization_Control.Requires_Late_Init (Decl, Rec_Type) then
if not Has_Late_Init_Comp then
Late_Stmts := New_List;
end if;
Has_Late_Init_Comp := True;
-- Regular component cases
@ -3403,17 +3356,56 @@ package body Exp_Ch3 is
elsif not Is_Interface (Typ)
and then Has_Non_Null_Base_Init_Proc (Typ)
then
Actions :=
Build_Initialization_Call
(Comp_Loc,
Make_Selected_Component (Comp_Loc,
Prefix =>
Make_Identifier (Comp_Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
Typ,
In_Init_Proc => True,
Enclos_Type => Rec_Type,
Discr_Map => Discr_Map);
declare
use Initialization_Control;
Init_Control_Actual : Node_Id := Empty;
Is_Parent : constant Boolean := Chars (Id) = Name_uParent;
Init_Call_Stmts : List_Id;
begin
if Is_Parent and then Has_Late_Init_Component (Etype (Id))
then
Init_Control_Actual :=
Make_Mode_Literal (Comp_Loc, Early_Init_Only);
-- Parent_Id used later in second call to parent's
-- init proc to initialize late-init components.
Parent_Id := Id;
end if;
Init_Call_Stmts :=
Build_Initialization_Call
(Comp_Loc,
Make_Selected_Component (Comp_Loc,
Prefix =>
Make_Identifier (Comp_Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Id, Comp_Loc)),
Typ,
In_Init_Proc => True,
Enclos_Type => Rec_Type,
Discr_Map => Discr_Map,
Init_Control_Actual => Init_Control_Actual);
if Is_Parent then
-- This is tricky. At first it looks like
-- we are going to end up with nested
-- if-statements with the same condition:
-- if Early_Init_Condition then
-- if Early_Init_Condition then
-- Parent_TypeIP (...);
-- end if;
-- end if;
-- But later we will hoist the inner if-statement
-- out of the outer one; we do this because the
-- init-proc call for the _Parent component of a type
-- extension has to precede any other initialization.
Actions :=
New_List (Make_If_Statement (Loc,
Condition =>
Early_Init_Condition (Loc, Init_Control_Formal),
Then_Statements => Init_Call_Stmts));
else
Actions := Init_Call_Stmts;
end if;
end;
Clean_Task_Names (Typ, Proc_Id);
@ -3443,7 +3435,7 @@ package body Exp_Ch3 is
-- DIC here.
if Has_DIC (Typ)
and then not Present (Expression (Decl))
and then No (Expression (Decl))
and then Present (DIC_Procedure (Typ))
and then not Has_Null_Body (DIC_Procedure (Typ))
@ -3481,7 +3473,6 @@ package body Exp_Ch3 is
if Present (Actions) then
if Chars (Id) = Name_uParent then
Append_List_To (Parent_Stmts, Actions);
else
Append_List_To (Stmts, Actions);
@ -3595,6 +3586,34 @@ package body Exp_Ch3 is
-- Second pass: components that require late initialization
if Present (Parent_Id) then
declare
Parent_Loc : constant Source_Ptr := Sloc (Parent (Parent_Id));
use Initialization_Control;
begin
-- We are building the init proc for a type extension.
-- Call the parent type's init proc a second time, this
-- time to initialize the parent's components that require
-- late initialization.
Append_List_To (Late_Stmts,
Build_Initialization_Call
(Loc => Parent_Loc,
Id_Ref =>
Make_Selected_Component (Parent_Loc,
Prefix => Make_Identifier
(Parent_Loc, Name_uInit),
Selector_Name => New_Occurrence_Of (Parent_Id,
Parent_Loc)),
Typ => Etype (Parent_Id),
In_Init_Proc => True,
Enclos_Type => Rec_Type,
Discr_Map => Discr_Map,
Init_Control_Actual => Make_Mode_Literal
(Parent_Loc, Late_Init_Only)));
end;
end if;
if Has_Late_Init_Comp then
Decl := First_Non_Pragma (Component_Items (Comp_List));
while Present (Decl) loop
@ -3602,13 +3621,14 @@ package body Exp_Ch3 is
Id := Defining_Identifier (Decl);
Typ := Etype (Id);
if Requires_Late_Initialization (Decl, Rec_Type) then
if Initialization_Control.Requires_Late_Init (Decl, Rec_Type)
then
if Present (Expression (Decl)) then
Append_List_To (Stmts,
Append_List_To (Late_Stmts,
Build_Assignment (Id, Expression (Decl)));
elsif Has_Non_Null_Base_Init_Proc (Typ) then
Append_List_To (Stmts,
Append_List_To (Late_Stmts,
Build_Initialization_Call (Comp_Loc,
Make_Selected_Component (Comp_Loc,
Prefix =>
@ -3628,10 +3648,10 @@ package body Exp_Ch3 is
Make_Counter (Comp_Loc);
end if;
Increment_Counter (Comp_Loc);
Increment_Counter (Comp_Loc, Late => True);
end if;
elsif Component_Needs_Simple_Initialization (Typ) then
Append_List_To (Stmts,
Append_List_To (Late_Stmts,
Build_Assignment
(Id => Id,
Default =>
@ -3646,7 +3666,8 @@ package body Exp_Ch3 is
end loop;
end if;
-- Process the variant part
-- Process the variant part (incorrectly ignoring late
-- initialization requirements for components therein).
if Present (Variant_Part (Comp_List)) then
declare
@ -3681,16 +3702,42 @@ package body Exp_Ch3 is
end;
end if;
-- If no initializations when generated for component declarations
-- corresponding to this Stmts, append a null statement to Stmts to
-- to make it a valid Ada tree.
if No (Init_Control_Formal) then
Append_List_To (Stmts, Late_Stmts);
if Is_Empty_List (Stmts) then
Append (Make_Null_Statement (Loc), Stmts);
-- If no initializations were generated for component declarations
-- and included in Stmts, then append a null statement to Stmts
-- to make it a valid Ada tree.
if Is_Empty_List (Stmts) then
Append (Make_Null_Statement (Loc), Stmts);
end if;
return Stmts;
else
declare
use Initialization_Control;
If_Early : constant Node_Id :=
(if Is_Empty_List (Stmts) then
Make_Null_Statement (Loc)
else
Make_If_Statement (Loc,
Condition =>
Early_Init_Condition (Loc, Init_Control_Formal),
Then_Statements => Stmts));
If_Late : constant Node_Id :=
(if Is_Empty_List (Late_Stmts) then
Make_Null_Statement (Loc)
else
Make_If_Statement (Loc,
Condition =>
Late_Init_Condition (Loc, Init_Control_Formal),
Then_Statements => Late_Stmts));
begin
return New_List (If_Early, If_Late);
end;
end if;
return Stmts;
exception
when RE_Not_Available =>
return Empty_List;
@ -9048,6 +9095,230 @@ package body Exp_Ch3 is
return Is_RTU (S1, System) or else Is_RTU (S1, Ada);
end In_Runtime;
package body Initialization_Control is
------------------------
-- Requires_Late_Init --
------------------------
function Requires_Late_Init
(Decl : Node_Id;
Rec_Type : Entity_Id) return Boolean
is
References_Current_Instance : Boolean := False;
Has_Access_Discriminant : Boolean := False;
Has_Internal_Call : Boolean := False;
function Find_Access_Discriminant
(N : Node_Id) return Traverse_Result;
-- Look for a name denoting an access discriminant
function Find_Current_Instance
(N : Node_Id) return Traverse_Result;
-- Look for a reference to the current instance of the type
function Find_Internal_Call
(N : Node_Id) return Traverse_Result;
-- Look for an internal protected function call
------------------------------
-- Find_Access_Discriminant --
------------------------------
function Find_Access_Discriminant
(N : Node_Id) return Traverse_Result is
begin
if Is_Entity_Name (N)
and then Denotes_Discriminant (N)
and then Is_Access_Type (Etype (N))
then
Has_Access_Discriminant := True;
return Abandon;
else
return OK;
end if;
end Find_Access_Discriminant;
---------------------------
-- Find_Current_Instance --
---------------------------
function Find_Current_Instance
(N : Node_Id) return Traverse_Result is
begin
if Is_Entity_Name (N)
and then Present (Entity (N))
and then Is_Current_Instance (N)
then
References_Current_Instance := True;
return Abandon;
else
return OK;
end if;
end Find_Current_Instance;
------------------------
-- Find_Internal_Call --
------------------------
function Find_Internal_Call (N : Node_Id) return Traverse_Result is
function Call_Scope (N : Node_Id) return Entity_Id;
-- Return the scope enclosing a given call node N
----------------
-- Call_Scope --
----------------
function Call_Scope (N : Node_Id) return Entity_Id is
Nam : constant Node_Id := Name (N);
begin
if Nkind (Nam) = N_Selected_Component then
return Scope (Entity (Prefix (Nam)));
else
return Scope (Entity (Nam));
end if;
end Call_Scope;
begin
if Nkind (N) = N_Function_Call
and then Call_Scope (N)
= Corresponding_Concurrent_Type (Rec_Type)
then
Has_Internal_Call := True;
return Abandon;
else
return OK;
end if;
end Find_Internal_Call;
procedure Search_Access_Discriminant is new
Traverse_Proc (Find_Access_Discriminant);
procedure Search_Current_Instance is new
Traverse_Proc (Find_Current_Instance);
procedure Search_Internal_Call is new
Traverse_Proc (Find_Internal_Call);
-- Start of processing for Requires_Late_Init
begin
-- A component of an object is said to require late initialization
-- if:
-- it has an access discriminant value constrained by a per-object
-- expression;
if Has_Access_Constraint (Defining_Identifier (Decl))
and then No (Expression (Decl))
then
return True;
elsif Present (Expression (Decl)) then
-- it has an initialization expression that includes a name
-- denoting an access discriminant;
Search_Access_Discriminant (Expression (Decl));
if Has_Access_Discriminant then
return True;
end if;
-- or it has an initialization expression that includes a
-- reference to the current instance of the type either by
-- name...
Search_Current_Instance (Expression (Decl));
if References_Current_Instance then
return True;
end if;
-- ...or implicitly as the target object of a call.
if Is_Protected_Record_Type (Rec_Type) then
Search_Internal_Call (Expression (Decl));
if Has_Internal_Call then
return True;
end if;
end if;
end if;
return False;
end Requires_Late_Init;
-----------------------------
-- Has_Late_Init_Component --
-----------------------------
function Has_Late_Init_Component
(Tagged_Rec_Type : Entity_Id) return Boolean
is
Comp_Id : Entity_Id :=
First_Component (Implementation_Base_Type (Tagged_Rec_Type));
begin
while Present (Comp_Id) loop
if Requires_Late_Init (Decl => Parent (Comp_Id),
Rec_Type => Tagged_Rec_Type)
then
return True; -- found a component that requires late init
elsif Chars (Comp_Id) = Name_uParent
and then Has_Late_Init_Component (Etype (Comp_Id))
then
return True; -- an ancestor type has a late init component
end if;
Next_Component (Comp_Id);
end loop;
return False;
end Has_Late_Init_Component;
------------------------
-- Tag_Init_Condition --
------------------------
function Tag_Init_Condition
(Loc : Source_Ptr;
Init_Control_Formal : Entity_Id) return Node_Id is
begin
return Make_Op_Eq (Loc,
New_Occurrence_Of (Init_Control_Formal, Loc),
Make_Mode_Literal (Loc, Full_Init));
end Tag_Init_Condition;
--------------------------
-- Early_Init_Condition --
--------------------------
function Early_Init_Condition
(Loc : Source_Ptr;
Init_Control_Formal : Entity_Id) return Node_Id is
begin
return Make_Op_Ne (Loc,
New_Occurrence_Of (Init_Control_Formal, Loc),
Make_Mode_Literal (Loc, Late_Init_Only));
end Early_Init_Condition;
-------------------------
-- Late_Init_Condition --
-------------------------
function Late_Init_Condition
(Loc : Source_Ptr;
Init_Control_Formal : Entity_Id) return Node_Id is
begin
return Make_Op_Ne (Loc,
New_Occurrence_Of (Init_Control_Formal, Loc),
Make_Mode_Literal (Loc, Early_Init_Only));
end Late_Init_Condition;
end Initialization_Control;
----------------------------
-- Initialization_Warning --
----------------------------

23
gcc/ada/exp_ch3.ads
View File

@ -62,14 +62,15 @@ package Exp_Ch3 is
-- and the discriminant checking functions are inserted after this node.
function Build_Initialization_Call
(Loc : Source_Ptr;
Id_Ref : Node_Id;
Typ : Entity_Id;
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List;
With_Default_Init : Boolean := False;
Constructor_Ref : Node_Id := Empty) return List_Id;
(Loc : Source_Ptr;
Id_Ref : Node_Id;
Typ : Entity_Id;
In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
Discr_Map : Elist_Id := New_Elmt_List;
With_Default_Init : Boolean := False;
Constructor_Ref : Node_Id := Empty;
Init_Control_Actual : Entity_Id := Empty) return List_Id;
-- Builds a call to the initialization procedure for the base type of Typ,
-- passing it the object denoted by Id_Ref, plus additional parameters as
-- appropriate for the type (the _Master, for task types, for example).
@ -93,6 +94,12 @@ package Exp_Ch3 is
--
-- Constructor_Ref is a call to a constructor subprogram. It is currently
-- used only to support C++ constructors.
--
-- Init_Control_Actual is Empty except in the case where the init proc
-- for a tagged type calls the init proc for its parent type in order
-- to initialize its _Parent component. In that case, it is the
-- actual parameter value corresponding to the Init_Control formal
-- parameter to be used in the call of the parent type's init proc.
function Build_Variant_Record_Equality
(Typ : Entity_Id;

9
gcc/ada/exp_util.adb
View File

@ -4377,6 +4377,12 @@ package body Exp_Util is
and then
Nkind (Expression (Parent (Id_Ref))) = N_Allocator;
Component_Suffix_Index : constant Int :=
(if In_Init_Proc then -1 else 0);
-- If an init proc calls Build_Task_Image_Decls twice for its
-- _Parent component (to split early/late initialization), we don't
-- want two decls with the same name. Hence, the -1 suffix.
begin
-- If Discard_Names or No_Implicit_Heap_Allocations are in effect,
-- generate a dummy declaration only.
@ -4418,7 +4424,8 @@ package body Exp_Util is
elsif Nkind (Id_Ref) = N_Selected_Component then
T_Id :=
Make_Defining_Identifier (Loc,
New_External_Name (Chars (Selector_Name (Id_Ref)), 'T'));
New_External_Name (Chars (Selector_Name (Id_Ref)), 'T',
Suffix_Index => Component_Suffix_Index));
Fun := Build_Task_Record_Image (Loc, Id_Ref, Is_Dyn);
elsif Nkind (Id_Ref) = N_Indexed_Component then