[multiple changes]
2014-07-18 Hristian Kirtchev <kirtchev@adacore.com> * einfo.adb Last_Aggregate_Assignment is now Node 30. (Last_Aggregate_Assignment): Include constants in the assertion. Update the underlying node. (Set_Last_Aggregate_Assignment): Include constants in the assertion. Update the underlying node. (Write_Field11_Name): Remove the entry for Last_Aggregate_Assignment. (Write_Field30_Name): Add an entry for Last_Aggregate_Assignment. * einfo.ads Update the node designation and usage of attribute Last_Aggregate_Assignment. * exp_aggr.adb (Expand_Array_Aggregate): Store the last assignment statement used to initialize a controlled object. (Late_Expansion): Store the last assignment statement used to initialize a controlled record or an array of controlled objects. * exp_ch3.adb (Expand_N_Object_Declaration): Default initialization of objects is now performed in a separate routine. (Default_Initialize_Object): New routine. * exp_ch7.adb (Build_BIP_Cleanup_Stmts): Add formal parameter Obj_Id. Update the comment on usage. (Find_Last_Init): Remove formal parameter Typ. Update comment on usage. Reimplement the logic. (Find_Last_Init_In_Block): New routine. (Is_Init_Call): Add formal parameter Init_Typ. Update the comment on usage. Account for the type init proc when trying to determine whether a statement is an initialization call. (Make_Adjust_Call): Rename formal parameter For_Parent to Skip_Self. Update all occurrences of For_Parent. Account for non-tagged types. Update the call to Make_Call. (Make_Call): Rename formal parameter For_Parent to Skip_Self. Update comment on usage. Update all occurrences of For_Parent. (Make_Final_Call): Rename formal parameter For_Parent to Skip_Self. Update all occurrences of For_Parent. Account for non-tagged types. Update the call to Make_Call. (Process_Object_Declaration): Most variables and constants are now local to the routine. * exp_ch7.ads (Make_Adjust_Call): Rename formal parameter For_Parent to Skip_Self. Update the comment on usage. (Make_Final_Call): Rename formal parameter For_Parent to Skip_Self. Update the comment on usage. 2014-07-18 Ed Schonberg <schonberg@adacore.com> * sem_ch9.adb (Analyze_Requeue): The entry being referenced can be a procedure that is implemented by entry, and have a formal that is a synchronized interface. It does not have to be declared as a protected operation. From-SVN: r212814
This commit is contained in:
parent
2941bf7dab
commit
4ac2bbbd05
|
@ -1,3 +1,50 @@
|
|||
2014-07-18 Hristian Kirtchev <kirtchev@adacore.com>
|
||||
|
||||
* einfo.adb Last_Aggregate_Assignment is now Node 30.
|
||||
(Last_Aggregate_Assignment): Include
|
||||
constants in the assertion. Update the underlying node.
|
||||
(Set_Last_Aggregate_Assignment): Include constants in the
|
||||
assertion. Update the underlying node. (Write_Field11_Name):
|
||||
Remove the entry for Last_Aggregate_Assignment.
|
||||
(Write_Field30_Name): Add an entry for Last_Aggregate_Assignment.
|
||||
* einfo.ads Update the node designation and usage of attribute
|
||||
Last_Aggregate_Assignment.
|
||||
* exp_aggr.adb (Expand_Array_Aggregate): Store the last
|
||||
assignment statement used to initialize a controlled object.
|
||||
(Late_Expansion): Store the last assignment statement used to
|
||||
initialize a controlled record or an array of controlled objects.
|
||||
* exp_ch3.adb (Expand_N_Object_Declaration): Default
|
||||
initialization of objects is now performed in a separate routine.
|
||||
(Default_Initialize_Object): New routine.
|
||||
* exp_ch7.adb (Build_BIP_Cleanup_Stmts): Add formal parameter
|
||||
Obj_Id. Update the comment on usage.
|
||||
(Find_Last_Init): Remove formal parameter Typ. Update comment on usage.
|
||||
Reimplement the logic. (Find_Last_Init_In_Block): New routine.
|
||||
(Is_Init_Call): Add formal parameter Init_Typ. Update the
|
||||
comment on usage. Account for the type init proc when trying
|
||||
to determine whether a statement is an initialization call.
|
||||
(Make_Adjust_Call): Rename formal parameter For_Parent to
|
||||
Skip_Self. Update all occurrences of For_Parent. Account for
|
||||
non-tagged types. Update the call to Make_Call.
|
||||
(Make_Call): Rename formal parameter For_Parent to Skip_Self. Update
|
||||
comment on usage. Update all occurrences of For_Parent.
|
||||
(Make_Final_Call): Rename formal parameter For_Parent to
|
||||
Skip_Self. Update all occurrences of For_Parent. Account
|
||||
for non-tagged types. Update the call to Make_Call.
|
||||
(Process_Object_Declaration): Most variables and constants are
|
||||
now local to the routine.
|
||||
* exp_ch7.ads (Make_Adjust_Call): Rename formal parameter
|
||||
For_Parent to Skip_Self. Update the comment on usage.
|
||||
(Make_Final_Call): Rename formal parameter For_Parent to
|
||||
Skip_Self. Update the comment on usage.
|
||||
|
||||
2014-07-18 Ed Schonberg <schonberg@adacore.com>
|
||||
|
||||
* sem_ch9.adb (Analyze_Requeue): The entry being referenced
|
||||
can be a procedure that is implemented by entry, and have a
|
||||
formal that is a synchronized interface. It does not have to
|
||||
be declared as a protected operation.
|
||||
|
||||
2014-07-18 Robert Dewar <dewar@adacore.com>
|
||||
|
||||
* gnat_rm.texi: Remove mention of obsolete attributes
|
||||
|
|
|
@ -101,7 +101,6 @@ package body Einfo is
|
|||
-- Entry_Component Node11
|
||||
-- Enumeration_Pos Uint11
|
||||
-- Generic_Homonym Node11
|
||||
-- Last_Aggregate_Assignment Node11
|
||||
-- Protected_Body_Subprogram Node11
|
||||
-- Block_Node Node11
|
||||
|
||||
|
@ -246,6 +245,7 @@ package body Einfo is
|
|||
-- Subprograms_For_Type Node29
|
||||
|
||||
-- Corresponding_Equality Node30
|
||||
-- Last_Aggregate_Assignment Node30
|
||||
-- Static_Initialization Node30
|
||||
|
||||
-- Thunk_Entity Node31
|
||||
|
@ -2433,8 +2433,8 @@ package body Einfo is
|
|||
|
||||
function Last_Aggregate_Assignment (Id : E) return N is
|
||||
begin
|
||||
pragma Assert (Ekind (Id) = E_Variable);
|
||||
return Node11 (Id);
|
||||
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
|
||||
return Node30 (Id);
|
||||
end Last_Aggregate_Assignment;
|
||||
|
||||
function Last_Assignment (Id : E) return N is
|
||||
|
@ -5195,8 +5195,8 @@ package body Einfo is
|
|||
|
||||
procedure Set_Last_Aggregate_Assignment (Id : E; V : N) is
|
||||
begin
|
||||
pragma Assert (Ekind (Id) = E_Variable);
|
||||
Set_Node11 (Id, V);
|
||||
pragma Assert (Ekind_In (Id, E_Constant, E_Variable));
|
||||
Set_Node30 (Id, V);
|
||||
end Set_Last_Aggregate_Assignment;
|
||||
|
||||
procedure Set_Last_Assignment (Id : E; V : N) is
|
||||
|
@ -8727,9 +8727,6 @@ package body Einfo is
|
|||
when E_Generic_Package =>
|
||||
Write_Str ("Generic_Homonym");
|
||||
|
||||
when E_Variable =>
|
||||
Write_Str ("Last_Aggregate_Assignment");
|
||||
|
||||
when E_Function |
|
||||
E_Procedure |
|
||||
E_Entry |
|
||||
|
@ -9526,6 +9523,10 @@ package body Einfo is
|
|||
when E_Function =>
|
||||
Write_Str ("Corresponding_Equality");
|
||||
|
||||
when E_Constant |
|
||||
E_Variable =>
|
||||
Write_Str ("Last_Aggregate_Assignment");
|
||||
|
||||
when E_Procedure =>
|
||||
Write_Str ("Static_Initialization");
|
||||
|
||||
|
|
|
@ -3068,11 +3068,11 @@ package Einfo is
|
|||
-- initialization, it may or may not be set if the type does have
|
||||
-- preelaborable initialization.
|
||||
|
||||
-- Last_Aggregate_Assignment (Node11)
|
||||
-- Applies to controlled variables initialized by an aggregate. Points to
|
||||
-- the last statement associated with the expansion of the aggregate. The
|
||||
-- attribute is used by the finalization machinery when marking an object
|
||||
-- as successfully initialized.
|
||||
-- Last_Aggregate_Assignment (Node30)
|
||||
-- Applies to controlled constants and variables initialized by an
|
||||
-- aggregate. Points to the last statement associated with the expansion
|
||||
-- of the aggregate. The attribute is used by the finalization machinery
|
||||
-- when marking an object as successfully initialized.
|
||||
|
||||
-- Last_Assignment (Node26)
|
||||
-- Defined in entities for variables, and OUT or IN OUT formals. Set for
|
||||
|
@ -5412,6 +5412,7 @@ package Einfo is
|
|||
-- Related_Type (Node27) (constants only)
|
||||
-- Initialization_Statements (Node28)
|
||||
-- BIP_Initialization_Call (Node29)
|
||||
-- Last_Aggregate_Assignment (Node30)
|
||||
-- Linker_Section_Pragma (Node33)
|
||||
-- Has_Alignment_Clause (Flag46)
|
||||
-- Has_Atomic_Components (Flag86)
|
||||
|
@ -6102,7 +6103,6 @@ package Einfo is
|
|||
-- Hiding_Loop_Variable (Node8)
|
||||
-- Current_Value (Node9)
|
||||
-- Encapsulating_State (Node10)
|
||||
-- Last_Aggregate_Assignment (Node11)
|
||||
-- Esize (Uint12)
|
||||
-- Extra_Accessibility (Node13)
|
||||
-- Alignment (Uint14)
|
||||
|
@ -6121,6 +6121,7 @@ package Einfo is
|
|||
-- Related_Type (Node27)
|
||||
-- Initialization_Statements (Node28)
|
||||
-- BIP_Initialization_Call (Node29)
|
||||
-- Last_Aggregate_Assignment (Node30)
|
||||
-- Linker_Section_Pragma (Node33)
|
||||
-- Contract (Node34)
|
||||
-- Has_Alignment_Clause (Flag46)
|
||||
|
|
|
@ -75,6 +75,15 @@ package body Exp_Aggr is
|
|||
type Case_Table_Type is array (Nat range <>) of Case_Bounds;
|
||||
-- Table type used by Check_Case_Choices procedure
|
||||
|
||||
procedure Collect_Initialization_Statements
|
||||
(Obj : Entity_Id;
|
||||
N : Node_Id;
|
||||
Node_After : Node_Id);
|
||||
-- If Obj is not frozen, collect actions inserted after N until, but not
|
||||
-- including, Node_After, for initialization of Obj, and move them to an
|
||||
-- expression with actions, which becomes the Initialization_Statements for
|
||||
-- Obj.
|
||||
|
||||
function Has_Default_Init_Comps (N : Node_Id) return Boolean;
|
||||
-- N is an aggregate (record or array). Checks the presence of default
|
||||
-- initialization (<>) in any component (Ada 2005: AI-287).
|
||||
|
@ -103,15 +112,6 @@ package body Exp_Aggr is
|
|||
-- statement of variant part will usually be small and probably in near
|
||||
-- sorted order.
|
||||
|
||||
procedure Collect_Initialization_Statements
|
||||
(Obj : Entity_Id;
|
||||
N : Node_Id;
|
||||
Node_After : Node_Id);
|
||||
-- If Obj is not frozen, collect actions inserted after N until, but not
|
||||
-- including, Node_After, for initialization of Obj, and move them to an
|
||||
-- expression with actions, which becomes the Initialization_Statements for
|
||||
-- Obj.
|
||||
|
||||
------------------------------------------------------
|
||||
-- Local subprograms for Record Aggregate Expansion --
|
||||
------------------------------------------------------
|
||||
|
@ -5233,6 +5233,19 @@ package body Exp_Aggr is
|
|||
Index => First_Index (Typ),
|
||||
Into => Target,
|
||||
Scalar_Comp => Is_Scalar_Type (Ctyp));
|
||||
|
||||
-- Save the last assignment statement associated with the aggregate
|
||||
-- when building a controlled object. This reference is utilized by
|
||||
-- the finalization machinery when marking an object as successfully
|
||||
-- initialized.
|
||||
|
||||
if Needs_Finalization (Typ)
|
||||
and then Is_Entity_Name (Target)
|
||||
and then Present (Entity (Target))
|
||||
and then Ekind_In (Entity (Target), E_Constant, E_Variable)
|
||||
then
|
||||
Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- If the aggregate is the expression in a declaration, the expanded
|
||||
|
@ -6210,23 +6223,8 @@ package body Exp_Aggr is
|
|||
if Is_Record_Type (Etype (N)) then
|
||||
Aggr_Code := Build_Record_Aggr_Code (N, Typ, Target);
|
||||
|
||||
-- Save the last assignment statement associated with the aggregate
|
||||
-- when building a controlled object. This reference is utilized by
|
||||
-- the finalization machinery when marking an object as successfully
|
||||
-- initialized.
|
||||
|
||||
if Needs_Finalization (Typ)
|
||||
and then Is_Entity_Name (Target)
|
||||
and then Present (Entity (Target))
|
||||
and then Ekind (Entity (Target)) = E_Variable
|
||||
then
|
||||
Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
|
||||
end if;
|
||||
|
||||
return Aggr_Code;
|
||||
|
||||
else pragma Assert (Is_Array_Type (Etype (N)));
|
||||
return
|
||||
Aggr_Code :=
|
||||
Build_Array_Aggr_Code
|
||||
(N => N,
|
||||
Ctype => Component_Type (Etype (N)),
|
||||
|
@ -6235,6 +6233,21 @@ package body Exp_Aggr is
|
|||
Scalar_Comp => Is_Scalar_Type (Component_Type (Typ)),
|
||||
Indexes => No_List);
|
||||
end if;
|
||||
|
||||
-- Save the last assignment statement associated with the aggregate
|
||||
-- when building a controlled object. This reference is utilized by
|
||||
-- the finalization machinery when marking an object as successfully
|
||||
-- initialized.
|
||||
|
||||
if Needs_Finalization (Typ)
|
||||
and then Is_Entity_Name (Target)
|
||||
and then Present (Entity (Target))
|
||||
and then Ekind_In (Entity (Target), E_Constant, E_Variable)
|
||||
then
|
||||
Set_Last_Aggregate_Assignment (Entity (Target), Last (Aggr_Code));
|
||||
end if;
|
||||
|
||||
return Aggr_Code;
|
||||
end Late_Expansion;
|
||||
|
||||
----------------------------------
|
||||
|
|
|
@ -2623,9 +2623,8 @@ package body Exp_Ch3 is
|
|||
|
||||
Statements => New_List (
|
||||
Make_Procedure_Call_Statement (Loc,
|
||||
Name =>
|
||||
Name =>
|
||||
New_Occurrence_Of (Local_DF_Id, Loc),
|
||||
|
||||
Parameter_Associations => New_List (
|
||||
Make_Identifier (Loc, Name_uInit),
|
||||
New_Occurrence_Of (Standard_False, Loc))),
|
||||
|
@ -4857,20 +4856,16 @@ package body Exp_Ch3 is
|
|||
Typ : constant Entity_Id := Etype (Def_Id);
|
||||
Base_Typ : constant Entity_Id := Base_Type (Typ);
|
||||
Expr_Q : Node_Id;
|
||||
Id_Ref : Node_Id;
|
||||
New_Ref : Node_Id;
|
||||
|
||||
Init_After : Node_Id := N;
|
||||
-- Node after which the init proc call is to be inserted. This is
|
||||
-- normally N, except for the case of a shared passive variable, in
|
||||
-- which case the init proc call must be inserted only after the bodies
|
||||
-- of the shared variable procedures have been seen.
|
||||
|
||||
function Build_Equivalent_Aggregate return Boolean;
|
||||
-- If the object has a constrained discriminated type and no initial
|
||||
-- value, it may be possible to build an equivalent aggregate instead,
|
||||
-- and prevent an actual call to the initialization procedure.
|
||||
|
||||
procedure Default_Initialize_Object (After : Node_Id);
|
||||
-- Generate all default initialization actions for object Def_Id. Any
|
||||
-- new code is inserted after node After.
|
||||
|
||||
function Rewrite_As_Renaming return Boolean;
|
||||
-- Indicate whether to rewrite a declaration with initialization into an
|
||||
-- object renaming declaration (see below).
|
||||
|
@ -4911,11 +4906,10 @@ package body Exp_Ch3 is
|
|||
end if;
|
||||
|
||||
if Ekind (Current_Scope) = E_Package
|
||||
and then
|
||||
(Restriction_Active (No_Elaboration_Code)
|
||||
or else Is_Preelaborated (Current_Scope))
|
||||
and then
|
||||
(Restriction_Active (No_Elaboration_Code)
|
||||
or else Is_Preelaborated (Current_Scope))
|
||||
then
|
||||
|
||||
-- Building a static aggregate is possible if the discriminants
|
||||
-- have static values and the other components have static
|
||||
-- defaults or none.
|
||||
|
@ -5005,6 +4999,263 @@ package body Exp_Ch3 is
|
|||
end if;
|
||||
end Build_Equivalent_Aggregate;
|
||||
|
||||
-------------------------------
|
||||
-- Default_Initialize_Object --
|
||||
-------------------------------
|
||||
|
||||
procedure Default_Initialize_Object (After : Node_Id) is
|
||||
function New_Object_Reference return Node_Id;
|
||||
-- Return a new reference to Def_Id with attributes Assignment_OK and
|
||||
-- Must_Not_Freeze already set.
|
||||
|
||||
--------------------------
|
||||
-- New_Object_Reference --
|
||||
--------------------------
|
||||
|
||||
function New_Object_Reference return Node_Id is
|
||||
Obj_Ref : constant Node_Id := New_Occurrence_Of (Def_Id, Loc);
|
||||
|
||||
begin
|
||||
-- The call to the type init proc or [Deep_]Finalize must not
|
||||
-- freeze the related object as the call is internally generated.
|
||||
-- This way legal rep clauses that apply to the object will not be
|
||||
-- flagged. Note that the initialization call may be removed if
|
||||
-- pragma Import is encountered or moved to the freeze actions of
|
||||
-- the object because of an address clause.
|
||||
|
||||
Set_Assignment_OK (Obj_Ref);
|
||||
Set_Must_Not_Freeze (Obj_Ref);
|
||||
|
||||
return Obj_Ref;
|
||||
end New_Object_Reference;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Abrt_HSS : Node_Id;
|
||||
Abrt_Id : Entity_Id;
|
||||
Abrt_Stmts : List_Id;
|
||||
Aggr_Init : Node_Id;
|
||||
Comp_Init : List_Id := No_List;
|
||||
Fin_Call : Node_Id;
|
||||
Fin_Stmts : List_Id := No_List;
|
||||
Obj_Init : Node_Id := Empty;
|
||||
Obj_Ref : Node_Id;
|
||||
|
||||
-- Start of processing for Default_Initialize_Object
|
||||
|
||||
begin
|
||||
-- Step 1: Initialize the object
|
||||
|
||||
if Needs_Finalization (Typ) and then not No_Initialization (N) then
|
||||
Obj_Init :=
|
||||
Make_Init_Call
|
||||
(Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
|
||||
Typ => Typ);
|
||||
end if;
|
||||
|
||||
-- Step 2: Initialize the components of the object
|
||||
|
||||
-- Do not initialize the components if their initialization is
|
||||
-- prohibited or the type represents a value type in a .NET VM.
|
||||
|
||||
if Has_Non_Null_Base_Init_Proc (Typ)
|
||||
and then not No_Initialization (N)
|
||||
and then not Initialization_Suppressed (Typ)
|
||||
and then not Is_Value_Type (Typ)
|
||||
then
|
||||
-- Do not initialize the components if No_Default_Initialization
|
||||
-- applies as the the actual restriction check will occur later
|
||||
-- when the object is frozen as it is not known yet whether the
|
||||
-- object is imported or not.
|
||||
|
||||
if not Restriction_Active (No_Default_Initialization) then
|
||||
|
||||
-- If the values of the components are compile-time known, use
|
||||
-- their prebuilt aggregate form directly.
|
||||
|
||||
Aggr_Init := Static_Initialization (Base_Init_Proc (Typ));
|
||||
|
||||
if Present (Aggr_Init) then
|
||||
Set_Expression
|
||||
(N, New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope));
|
||||
|
||||
-- If type has discriminants, try to build an equivalent
|
||||
-- aggregate using discriminant values from the declaration.
|
||||
-- This is a useful optimization, in particular if restriction
|
||||
-- No_Elaboration_Code is active.
|
||||
|
||||
elsif Build_Equivalent_Aggregate then
|
||||
null;
|
||||
|
||||
-- Otherwise invoke the type init proc
|
||||
|
||||
else
|
||||
Obj_Ref := New_Object_Reference;
|
||||
|
||||
if Comes_From_Source (Def_Id) then
|
||||
Initialization_Warning (Obj_Ref);
|
||||
end if;
|
||||
|
||||
Comp_Init := Build_Initialization_Call (Loc, Obj_Ref, Typ);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Provide a default value if the object needs simple initialization
|
||||
-- and does not already have an initial value. A generated temporary
|
||||
-- do not require initialization because it will be assigned later.
|
||||
|
||||
elsif Needs_Simple_Initialization
|
||||
(Typ, Initialize_Scalars
|
||||
and then not Has_Following_Address_Clause (N))
|
||||
and then not Is_Internal (Def_Id)
|
||||
and then not Has_Init_Expression (N)
|
||||
then
|
||||
Set_No_Initialization (N, False);
|
||||
Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
|
||||
Analyze_And_Resolve (Expression (N), Typ);
|
||||
end if;
|
||||
|
||||
-- Step 3: Add partial finalization and abort actions, generate:
|
||||
|
||||
-- Type_Init_Proc (Obj);
|
||||
-- begin
|
||||
-- Deep_Initialize (Obj);
|
||||
-- exception
|
||||
-- when others =>
|
||||
-- Deep_Finalize (Obj, Self => False);
|
||||
-- raise;
|
||||
-- end;
|
||||
|
||||
-- Step 3a: Build the finalization block (if applicable)
|
||||
|
||||
-- The finalization block is required when both the object and its
|
||||
-- controlled components are to be initialized. The block finalizes
|
||||
-- the components if the object initialization fails.
|
||||
|
||||
if Has_Controlled_Component (Typ)
|
||||
and then Present (Comp_Init)
|
||||
and then Present (Obj_Init)
|
||||
and then not Restriction_Active (No_Exception_Propagation)
|
||||
then
|
||||
-- Generate:
|
||||
-- Type_Init_Proc (Obj);
|
||||
|
||||
Fin_Stmts := Comp_Init;
|
||||
|
||||
-- Generate:
|
||||
-- begin
|
||||
-- Deep_Initialize (Obj);
|
||||
-- exception
|
||||
-- when others =>
|
||||
-- Deep_Finalize (Obj, Self => False);
|
||||
-- raise;
|
||||
-- end;
|
||||
|
||||
Fin_Call :=
|
||||
Make_Final_Call
|
||||
(Obj_Ref => New_Object_Reference,
|
||||
Typ => Typ,
|
||||
Skip_Self => True);
|
||||
|
||||
if Present (Fin_Call) then
|
||||
|
||||
-- Do not emit warnings related to the elaboration order when a
|
||||
-- controlled object is declared before the body of Finalize is
|
||||
-- seen.
|
||||
|
||||
Set_No_Elaboration_Check (Fin_Call);
|
||||
|
||||
Append_To (Fin_Stmts,
|
||||
Make_Block_Statement (Loc,
|
||||
Declarations => No_List,
|
||||
|
||||
Handled_Statement_Sequence =>
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
Statements => New_List (Obj_Init),
|
||||
|
||||
Exception_Handlers => New_List (
|
||||
Make_Exception_Handler (Loc,
|
||||
Exception_Choices => New_List (
|
||||
Make_Others_Choice (Loc)),
|
||||
|
||||
Statements => New_List (
|
||||
Fin_Call,
|
||||
Make_Raise_Statement (Loc)))))));
|
||||
end if;
|
||||
|
||||
-- Finalization is not required, the initialization calls are passed
|
||||
-- to the abort block building circuitry, generate:
|
||||
|
||||
-- Type_Init_Proc (Obj);
|
||||
-- Deep_Initialize (Obj);
|
||||
|
||||
else
|
||||
if Present (Comp_Init) then
|
||||
Fin_Stmts := Comp_Init;
|
||||
end if;
|
||||
|
||||
if Present (Obj_Init) then
|
||||
if No (Fin_Stmts) then
|
||||
Fin_Stmts := New_List;
|
||||
end if;
|
||||
|
||||
Append_To (Fin_Stmts, Obj_Init);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Step 3b: Build the abort block (if applicable)
|
||||
|
||||
-- The abort block is required when aborts are allowed and there is
|
||||
-- at least one initialization call that needs protection.
|
||||
|
||||
if Abort_Allowed
|
||||
and then Present (Comp_Init)
|
||||
and then Present (Obj_Init)
|
||||
then
|
||||
-- Generate:
|
||||
-- Abort_Defer;
|
||||
|
||||
Prepend_To (Fin_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
|
||||
|
||||
-- Generate:
|
||||
-- begin
|
||||
-- Abort_Defer;
|
||||
-- <finalization statements>
|
||||
-- at end
|
||||
-- Abort_Undefer_Direct;
|
||||
-- end;
|
||||
|
||||
Abrt_Id := New_Internal_Entity (E_Block, Current_Scope, Loc, 'B');
|
||||
Set_Etype (Abrt_Id, Standard_Void_Type);
|
||||
Set_Scope (Abrt_Id, Current_Scope);
|
||||
|
||||
Abrt_HSS :=
|
||||
Make_Handled_Sequence_Of_Statements (Loc,
|
||||
Statements => Fin_Stmts,
|
||||
At_End_Proc =>
|
||||
New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
|
||||
|
||||
Abrt_Stmts := New_List (
|
||||
Make_Block_Statement (Loc,
|
||||
Identifier => New_Occurrence_Of (Abrt_Id, Loc),
|
||||
Declarations => No_List,
|
||||
Handled_Statement_Sequence => Abrt_HSS));
|
||||
|
||||
Expand_At_End_Handler (Abrt_HSS, Abrt_Id);
|
||||
|
||||
-- Abort is not required, the construct from Step 3a is to be added
|
||||
-- in the tree (either finalization block or single initialization
|
||||
-- call).
|
||||
|
||||
else
|
||||
Abrt_Stmts := Fin_Stmts;
|
||||
end if;
|
||||
|
||||
-- Step 4: Insert the whole initialization sequence into the tree
|
||||
|
||||
Insert_Actions_After (After, Abrt_Stmts);
|
||||
end Default_Initialize_Object;
|
||||
|
||||
-------------------------
|
||||
-- Rewrite_As_Renaming --
|
||||
-------------------------
|
||||
|
@ -5018,6 +5269,17 @@ package body Exp_Ch3 is
|
|||
and then Is_Entity_Name (Obj_Def);
|
||||
end Rewrite_As_Renaming;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Id_Ref : Node_Id;
|
||||
New_Ref : Node_Id;
|
||||
|
||||
Init_After : Node_Id := N;
|
||||
-- Node after which the initialization actions are to be inserted. This
|
||||
-- is normally N, except for the case of a shared passive variable, in
|
||||
-- which case the init proc call must be inserted only after the bodies
|
||||
-- of the shared variable procedures have been seen.
|
||||
|
||||
-- Start of processing for Expand_N_Object_Declaration
|
||||
|
||||
begin
|
||||
|
@ -5118,153 +5380,7 @@ package body Exp_Ch3 is
|
|||
Make_Invariant_Call (New_Occurrence_Of (Def_Id, Loc)));
|
||||
end if;
|
||||
|
||||
-- Expand Initialize call for controlled objects. One may wonder why
|
||||
-- the Initialize Call is not done in the regular Init procedure
|
||||
-- attached to the record type. That's because the init procedure is
|
||||
-- recursively called on each component, including _Parent, thus the
|
||||
-- Init call for a controlled object would generate not only one
|
||||
-- Initialize call as it is required but one for each ancestor of
|
||||
-- its type. This processing is suppressed if No_Initialization set.
|
||||
|
||||
if not Needs_Finalization (Typ) or else No_Initialization (N) then
|
||||
null;
|
||||
|
||||
elsif not Abort_Allowed or else not Comes_From_Source (N) then
|
||||
Insert_Action_After (Init_After,
|
||||
Make_Init_Call
|
||||
(Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
|
||||
Typ => Base_Typ));
|
||||
|
||||
-- Abort allowed
|
||||
|
||||
else
|
||||
-- We need to protect the initialize call
|
||||
|
||||
-- begin
|
||||
-- Defer_Abort.all;
|
||||
-- Initialize (...);
|
||||
-- at end
|
||||
-- Undefer_Abort.all;
|
||||
-- end;
|
||||
|
||||
-- ??? this won't protect the initialize call for controlled
|
||||
-- components which are part of the init proc, so this block
|
||||
-- should probably also contain the call to _init_proc but this
|
||||
-- requires some code reorganization...
|
||||
|
||||
declare
|
||||
L : constant List_Id := New_List (
|
||||
Make_Init_Call
|
||||
(Obj_Ref => New_Occurrence_Of (Def_Id, Loc),
|
||||
Typ => Base_Typ));
|
||||
|
||||
Blk : constant Node_Id :=
|
||||
Make_Block_Statement (Loc,
|
||||
Handled_Statement_Sequence =>
|
||||
Make_Handled_Sequence_Of_Statements (Loc, L));
|
||||
|
||||
begin
|
||||
Prepend_To (L, Build_Runtime_Call (Loc, RE_Abort_Defer));
|
||||
Set_At_End_Proc (Handled_Statement_Sequence (Blk),
|
||||
New_Occurrence_Of (RTE (RE_Abort_Undefer_Direct), Loc));
|
||||
Insert_Actions_After (Init_After, New_List (Blk));
|
||||
Expand_At_End_Handler
|
||||
(Handled_Statement_Sequence (Blk), Entity (Identifier (Blk)));
|
||||
end;
|
||||
end if;
|
||||
|
||||
-- Call type initialization procedure if there is one. We build the
|
||||
-- call and put it immediately after the object declaration, so that
|
||||
-- it will be expanded in the usual manner. Note that this will
|
||||
-- result in proper handling of defaulted discriminants.
|
||||
|
||||
-- Need call if there is a base init proc
|
||||
|
||||
if Has_Non_Null_Base_Init_Proc (Typ)
|
||||
|
||||
-- Suppress call if No_Initialization set on declaration
|
||||
|
||||
and then not No_Initialization (N)
|
||||
|
||||
-- Suppress call for special case of value type for VM
|
||||
|
||||
and then not Is_Value_Type (Typ)
|
||||
|
||||
-- Suppress call if initialization suppressed for the type
|
||||
|
||||
and then not Initialization_Suppressed (Typ)
|
||||
then
|
||||
-- Return without initializing when No_Default_Initialization
|
||||
-- applies. Note that the actual restriction check occurs later,
|
||||
-- when the object is frozen, because we don't know yet whether
|
||||
-- the object is imported, which is a case where the check does
|
||||
-- not apply.
|
||||
|
||||
if Restriction_Active (No_Default_Initialization) then
|
||||
return;
|
||||
end if;
|
||||
|
||||
-- The call to the initialization procedure does NOT freeze the
|
||||
-- object being initialized. This is because the call is not a
|
||||
-- source level call. This works fine, because the only possible
|
||||
-- statements depending on freeze status that can appear after the
|
||||
-- Init_Proc call are rep clauses which can safely appear after
|
||||
-- actual references to the object. Note that this call may
|
||||
-- subsequently be removed (if a pragma Import is encountered),
|
||||
-- or moved to the freeze actions for the object (e.g. if an
|
||||
-- address clause is applied to the object, causing it to get
|
||||
-- delayed freezing).
|
||||
|
||||
Id_Ref := New_Occurrence_Of (Def_Id, Loc);
|
||||
Set_Must_Not_Freeze (Id_Ref);
|
||||
Set_Assignment_OK (Id_Ref);
|
||||
|
||||
declare
|
||||
Init_Expr : constant Node_Id :=
|
||||
Static_Initialization (Base_Init_Proc (Typ));
|
||||
|
||||
begin
|
||||
if Present (Init_Expr) then
|
||||
Set_Expression
|
||||
(N, New_Copy_Tree (Init_Expr, New_Scope => Current_Scope));
|
||||
return;
|
||||
|
||||
-- If type has discriminants, try to build equivalent aggregate
|
||||
-- using discriminant values from the declaration. This
|
||||
-- is a useful optimization, in particular if restriction
|
||||
-- No_Elaboration_Code is active.
|
||||
|
||||
elsif Build_Equivalent_Aggregate then
|
||||
return;
|
||||
|
||||
else
|
||||
Initialization_Warning (Id_Ref);
|
||||
|
||||
Insert_Actions_After (Init_After,
|
||||
Build_Initialization_Call (Loc, Id_Ref, Typ));
|
||||
end if;
|
||||
end;
|
||||
|
||||
-- If simple initialization is required, then set an appropriate
|
||||
-- simple initialization expression in place. This special
|
||||
-- initialization is required even though No_Init_Flag is present,
|
||||
-- but is not needed if there was an explicit initialization.
|
||||
|
||||
-- An internally generated temporary needs no initialization because
|
||||
-- it will be assigned subsequently. In particular, there is no point
|
||||
-- in applying Initialize_Scalars to such a temporary.
|
||||
|
||||
elsif Needs_Simple_Initialization
|
||||
(Typ,
|
||||
Initialize_Scalars
|
||||
and then not Has_Following_Address_Clause (N))
|
||||
and then not Is_Internal (Def_Id)
|
||||
and then not Has_Init_Expression (N)
|
||||
then
|
||||
Set_No_Initialization (N, False);
|
||||
Set_Expression (N, Get_Simple_Init_Val (Typ, N, Esize (Def_Id)));
|
||||
Analyze_And_Resolve (Expression (N), Typ);
|
||||
end if;
|
||||
Default_Initialize_Object (Init_After);
|
||||
|
||||
-- Generate attribute for Persistent_BSS if needed
|
||||
|
||||
|
@ -7971,8 +8087,8 @@ package body Exp_Ch3 is
|
|||
|
||||
if Warning_Needed then
|
||||
Error_Msg_N
|
||||
("Objects of the type cannot be initialized "
|
||||
& "statically by default??", Parent (E));
|
||||
("Objects of the type cannot be initialized statically "
|
||||
& "by default??", Parent (E));
|
||||
end if;
|
||||
end if;
|
||||
|
||||
|
|
|
@ -380,14 +380,14 @@ package body Exp_Ch7 is
|
|||
-- Initial_Condition. N denotes the package spec or body.
|
||||
|
||||
function Make_Call
|
||||
(Loc : Source_Ptr;
|
||||
Proc_Id : Entity_Id;
|
||||
Param : Node_Id;
|
||||
For_Parent : Boolean := False) return Node_Id;
|
||||
(Loc : Source_Ptr;
|
||||
Proc_Id : Entity_Id;
|
||||
Param : Node_Id;
|
||||
Skip_Self : Boolean := False) return Node_Id;
|
||||
-- Subsidiary to Make_Adjust_Call and Make_Final_Call. Given the entity of
|
||||
-- routine [Deep_]Adjust / Finalize and an object parameter, create an
|
||||
-- adjust / finalization call. Flag For_Parent should be set when field
|
||||
-- _parent is being processed.
|
||||
-- routine [Deep_]Adjust or [Deep_]Finalize and an object parameter, create
|
||||
-- an adjust or finalization call. Wnen flag Skip_Self is set, the related
|
||||
-- action has an effect on the components only (if any).
|
||||
|
||||
function Make_Deep_Proc
|
||||
(Prim : Final_Primitives;
|
||||
|
@ -2066,22 +2066,13 @@ package body Exp_Ch7 is
|
|||
Has_No_Init : Boolean := False;
|
||||
Is_Protected : Boolean := False)
|
||||
is
|
||||
Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
|
||||
Loc : constant Source_Ptr := Sloc (Decl);
|
||||
Body_Ins : Node_Id;
|
||||
Count_Ins : Node_Id;
|
||||
Fin_Call : Node_Id;
|
||||
Fin_Stmts : List_Id;
|
||||
Inc_Decl : Node_Id;
|
||||
Label : Node_Id;
|
||||
Label_Id : Entity_Id;
|
||||
Obj_Ref : Node_Id;
|
||||
Obj_Typ : Entity_Id;
|
||||
Loc : constant Source_Ptr := Sloc (Decl);
|
||||
|
||||
function Build_BIP_Cleanup_Stmts (Func_Id : Entity_Id) return Node_Id;
|
||||
-- Once it has been established that the current object is in fact a
|
||||
-- return object of build-in-place function Func_Id, generate the
|
||||
-- following cleanup code:
|
||||
function Build_BIP_Cleanup_Stmts
|
||||
(Func_Id : Entity_Id;
|
||||
Obj_Id : Entity_Id) return Node_Id;
|
||||
-- Func_Id denotes a build-in-place function. Obj_Id is the return
|
||||
-- object of Func_Id. Generate the following cleanup code:
|
||||
--
|
||||
-- if BIPallocfrom > Secondary_Stack'Pos
|
||||
-- and then BIPfinalizationmaster /= null
|
||||
|
@ -2100,21 +2091,20 @@ package body Exp_Ch7 is
|
|||
|
||||
procedure Find_Last_Init
|
||||
(Decl : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Last_Init : out Node_Id;
|
||||
Body_Insert : out Node_Id);
|
||||
-- An object declaration has at least one and at most two init calls:
|
||||
-- that of the type and the user-defined initialize. Given an object
|
||||
-- declaration, Last_Init denotes the last initialization call which
|
||||
-- follows the declaration. Body_Insert denotes the place where the
|
||||
-- finalizer body could be potentially inserted.
|
||||
-- Find the last initialization call related to object declaration
|
||||
-- Decl. Last_Init denotes the last initialization call which follows
|
||||
-- Decl. Body_Insert denotes the finalizer body could be potentially
|
||||
-- inserted.
|
||||
|
||||
-----------------------------
|
||||
-- Build_BIP_Cleanup_Stmts --
|
||||
-----------------------------
|
||||
|
||||
function Build_BIP_Cleanup_Stmts
|
||||
(Func_Id : Entity_Id) return Node_Id
|
||||
(Func_Id : Entity_Id;
|
||||
Obj_Id : Entity_Id) return Node_Id
|
||||
is
|
||||
Decls : constant List_Id := New_List;
|
||||
Fin_Mas_Id : constant Entity_Id :=
|
||||
|
@ -2255,58 +2245,109 @@ package body Exp_Ch7 is
|
|||
|
||||
procedure Find_Last_Init
|
||||
(Decl : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Last_Init : out Node_Id;
|
||||
Body_Insert : out Node_Id)
|
||||
is
|
||||
function Find_Last_Init_In_Block
|
||||
(Blk : Node_Id;
|
||||
Init_Typ : Entity_Id) return Node_Id;
|
||||
-- Find the last initialization call within the statements of
|
||||
-- block Blk. Init_Typ is type of the object being initialized.
|
||||
|
||||
function Is_Init_Call
|
||||
(N : Node_Id;
|
||||
Typ : Entity_Id) return Boolean;
|
||||
-- Given an arbitrary node, determine whether N is a procedure
|
||||
-- call and if it is, try to match the name of the call with the
|
||||
-- [Deep_]Initialize proc of Typ.
|
||||
(N : Node_Id;
|
||||
Init_Typ : Entity_Id) return Boolean;
|
||||
-- Determine whether node N denotes one of the initialization
|
||||
-- procedures of type Init_Typ.
|
||||
|
||||
function Next_Suitable_Statement (Stmt : Node_Id) return Node_Id;
|
||||
-- Given a statement which is part of a list, return the next
|
||||
-- real statement while skipping over dynamic elab checks.
|
||||
-- statement while skipping over dynamic elab checks.
|
||||
|
||||
-----------------------------
|
||||
-- Find_Last_Init_In_Block --
|
||||
-----------------------------
|
||||
|
||||
function Find_Last_Init_In_Block
|
||||
(Blk : Node_Id;
|
||||
Init_Typ : Entity_Id) return Node_Id
|
||||
is
|
||||
HSS : constant Node_Id := Handled_Statement_Sequence (Blk);
|
||||
Stmt : Node_Id;
|
||||
|
||||
begin
|
||||
-- Examine the individual statements of the block in reverse to
|
||||
-- locate the last initialization call.
|
||||
|
||||
if Present (HSS) and then Present (Statements (HSS)) then
|
||||
Stmt := Last (Statements (HSS));
|
||||
while Present (Stmt) loop
|
||||
|
||||
-- Peek inside nested blocks in case aborts are allowed
|
||||
|
||||
if Nkind (Stmt) = N_Block_Statement then
|
||||
return Find_Last_Init_In_Block (Stmt, Init_Typ);
|
||||
|
||||
elsif Is_Init_Call (Stmt, Init_Typ) then
|
||||
return Stmt;
|
||||
end if;
|
||||
|
||||
Prev (Stmt);
|
||||
end loop;
|
||||
end if;
|
||||
|
||||
return Empty;
|
||||
end Find_Last_Init_In_Block;
|
||||
|
||||
------------------
|
||||
-- Is_Init_Call --
|
||||
------------------
|
||||
|
||||
function Is_Init_Call
|
||||
(N : Node_Id;
|
||||
Typ : Entity_Id) return Boolean
|
||||
(N : Node_Id;
|
||||
Init_Typ : Entity_Id) return Boolean
|
||||
is
|
||||
begin
|
||||
-- A call to [Deep_]Initialize is always direct
|
||||
Call_Id : Entity_Id;
|
||||
Deep_Init : Entity_Id := Empty;
|
||||
Prim_Init : Entity_Id := Empty;
|
||||
Type_Init : Entity_Id := Empty;
|
||||
|
||||
begin
|
||||
if Nkind (N) = N_Procedure_Call_Statement
|
||||
and then Nkind (Name (N)) = N_Identifier
|
||||
then
|
||||
declare
|
||||
Call_Ent : constant Entity_Id := Entity (Name (N));
|
||||
Deep_Init : constant Entity_Id :=
|
||||
TSS (Typ, TSS_Deep_Initialize);
|
||||
Init : Entity_Id := Empty;
|
||||
Call_Id := Entity (Name (N));
|
||||
|
||||
begin
|
||||
-- A type may have controlled components but not be
|
||||
-- controlled.
|
||||
-- Obtain all possible initialization routines of the object
|
||||
-- type and try to match the procedure call against one of
|
||||
-- them.
|
||||
|
||||
if Is_Controlled (Typ) then
|
||||
Init := Find_Prim_Op (Typ, Name_Initialize);
|
||||
-- Deep_Initialize
|
||||
|
||||
if Present (Init) then
|
||||
Init := Ultimate_Alias (Init);
|
||||
end if;
|
||||
Deep_Init := TSS (Init_Typ, TSS_Deep_Initialize);
|
||||
|
||||
-- Primitive Initialize
|
||||
|
||||
if Is_Controlled (Init_Typ) then
|
||||
Prim_Init := Find_Prim_Op (Init_Typ, Name_Initialize);
|
||||
|
||||
if Present (Prim_Init) then
|
||||
Prim_Init := Ultimate_Alias (Prim_Init);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
return
|
||||
(Present (Deep_Init) and then Call_Ent = Deep_Init)
|
||||
or else
|
||||
(Present (Init) and then Call_Ent = Init);
|
||||
end;
|
||||
-- Type initialization routine
|
||||
|
||||
if Has_Non_Null_Base_Init_Proc (Init_Typ) then
|
||||
Type_Init := Base_Init_Proc (Init_Typ);
|
||||
end if;
|
||||
|
||||
return
|
||||
(Present (Deep_Init) and then Call_Id = Deep_Init)
|
||||
or else
|
||||
(Present (Prim_Init) and then Call_Id = Prim_Init)
|
||||
or else
|
||||
(Present (Type_Init) and then Call_Id = Type_Init);
|
||||
end if;
|
||||
|
||||
return False;
|
||||
|
@ -2333,11 +2374,13 @@ package body Exp_Ch7 is
|
|||
|
||||
-- Local variables
|
||||
|
||||
Obj_Id : constant Entity_Id := Defining_Entity (Decl);
|
||||
Nod_1 : Node_Id := Empty;
|
||||
Nod_2 : Node_Id := Empty;
|
||||
Stmt : Node_Id;
|
||||
Utyp : Entity_Id;
|
||||
Obj_Id : constant Entity_Id := Defining_Entity (Decl);
|
||||
Obj_Typ : constant Entity_Id := Base_Type (Etype (Obj_Id));
|
||||
Call : Node_Id;
|
||||
Init_Typ : Entity_Id := Obj_Typ;
|
||||
Is_Conc : Boolean := False;
|
||||
Stmt : Node_Id;
|
||||
Stmt_2 : Node_Id;
|
||||
|
||||
-- Start of processing for Find_Last_Init
|
||||
|
||||
|
@ -2346,23 +2389,41 @@ package body Exp_Ch7 is
|
|||
Body_Insert := Empty;
|
||||
|
||||
-- Object renamings and objects associated with controlled
|
||||
-- function results do not have initialization calls.
|
||||
-- function results do not require initialization.
|
||||
|
||||
if Has_No_Init then
|
||||
return;
|
||||
end if;
|
||||
|
||||
if Is_Concurrent_Type (Typ) then
|
||||
Utyp := Corresponding_Record_Type (Typ);
|
||||
else
|
||||
Utyp := Typ;
|
||||
-- Obtain the proper type of the object being initialized
|
||||
|
||||
loop
|
||||
if Is_Concurrent_Type (Init_Typ)
|
||||
and then Present (Corresponding_Record_Type (Init_Typ))
|
||||
then
|
||||
Is_Conc := True;
|
||||
Init_Typ := Corresponding_Record_Type (Init_Typ);
|
||||
|
||||
elsif Is_Private_Type (Init_Typ)
|
||||
and then Present (Full_View (Init_Typ))
|
||||
then
|
||||
Init_Typ := Full_View (Init_Typ);
|
||||
|
||||
elsif Is_Untagged_Derivation (Init_Typ)
|
||||
and then not Is_Conc
|
||||
then
|
||||
Init_Typ := Root_Type (Init_Typ);
|
||||
|
||||
else
|
||||
exit;
|
||||
end if;
|
||||
end loop;
|
||||
|
||||
if Init_Typ /= Base_Type (Init_Typ) then
|
||||
Init_Typ := Base_Type (Init_Typ);
|
||||
end if;
|
||||
|
||||
if Is_Private_Type (Utyp)
|
||||
and then Present (Full_View (Utyp))
|
||||
then
|
||||
Utyp := Full_View (Utyp);
|
||||
end if;
|
||||
Stmt := Next_Suitable_Statement (Decl);
|
||||
|
||||
-- A limited controlled object initialized by a function call uses
|
||||
-- the build-in-place machinery to obtain its value.
|
||||
|
@ -2381,11 +2442,10 @@ package body Exp_Ch7 is
|
|||
-- In this scenario the declaration of the temporary acts as the
|
||||
-- last initialization statement.
|
||||
|
||||
if Is_Limited_Type (Utyp)
|
||||
if Is_Limited_Type (Init_Typ)
|
||||
and then Has_Init_Expression (Decl)
|
||||
and then No (Expression (Decl))
|
||||
then
|
||||
Stmt := Next (Decl);
|
||||
while Present (Stmt) loop
|
||||
if Nkind (Stmt) = N_Object_Declaration
|
||||
and then Present (Expression (Stmt))
|
||||
|
@ -2400,68 +2460,77 @@ package body Exp_Ch7 is
|
|||
Next (Stmt);
|
||||
end loop;
|
||||
|
||||
-- The init procedures are arranged as follows:
|
||||
-- In all other cases the initialization calls follow the related
|
||||
-- object. The general structure of object initialization built by
|
||||
-- routine Default_Initialize_Object is as follows:
|
||||
|
||||
-- Object : Controlled_Type;
|
||||
-- Controlled_TypeIP (Object);
|
||||
-- [[Deep_]Initialize (Object);]
|
||||
-- [begin -- aborts allowed
|
||||
-- Abort_Defer;]
|
||||
-- Type_Init_Proc (Obj);
|
||||
-- [begin] -- exceptions allowed
|
||||
-- Deep_Initialize (Obj);
|
||||
-- [exception -- exceptions allowed
|
||||
-- when others =>
|
||||
-- Deep_Finalize (Obj, Self => False);
|
||||
-- raise;
|
||||
-- end;]
|
||||
-- [at end -- aborts allowed
|
||||
-- Abort_Undefer;
|
||||
-- end;]
|
||||
|
||||
-- where the user-defined initialize may be optional or may appear
|
||||
-- inside a block when abort deferral is needed.
|
||||
-- When aborts are allowed, the initialization calls are housed
|
||||
-- within a block.
|
||||
|
||||
elsif Nkind (Stmt) = N_Block_Statement then
|
||||
Last_Init := Find_Last_Init_In_Block (Stmt, Init_Typ);
|
||||
Body_Insert := Stmt;
|
||||
|
||||
-- Otherwise the initialization calls follow the related object
|
||||
|
||||
else
|
||||
Nod_1 := Next_Suitable_Statement (Decl);
|
||||
Stmt_2 := Next_Suitable_Statement (Stmt);
|
||||
|
||||
if Present (Nod_1) then
|
||||
Nod_2 := Next_Suitable_Statement (Nod_1);
|
||||
-- Check for an optional call to Deep_Initialize which may
|
||||
-- appear within a block depending on whether the object has
|
||||
-- controlled components.
|
||||
|
||||
-- The statement following an object declaration is always a
|
||||
-- call to the type init proc.
|
||||
if Present (Stmt_2) then
|
||||
if Nkind (Stmt_2) = N_Block_Statement then
|
||||
Call := Find_Last_Init_In_Block (Stmt_2, Init_Typ);
|
||||
|
||||
Last_Init := Nod_1;
|
||||
end if;
|
||||
if Present (Call) then
|
||||
Last_Init := Call;
|
||||
Body_Insert := Stmt_2;
|
||||
end if;
|
||||
|
||||
-- Optional user-defined init or deep init processing
|
||||
|
||||
if Present (Nod_2) then
|
||||
|
||||
-- The statement following the type init proc may be a block
|
||||
-- statement in cases where abort deferral is required.
|
||||
|
||||
if Nkind (Nod_2) = N_Block_Statement then
|
||||
declare
|
||||
HSS : constant Node_Id :=
|
||||
Handled_Statement_Sequence (Nod_2);
|
||||
Stmt : Node_Id;
|
||||
|
||||
begin
|
||||
if Present (HSS)
|
||||
and then Present (Statements (HSS))
|
||||
then
|
||||
-- Examine individual block statements and locate
|
||||
-- the call to [Deep_]Initialze.
|
||||
|
||||
Stmt := First (Statements (HSS));
|
||||
while Present (Stmt) loop
|
||||
if Is_Init_Call (Stmt, Utyp) then
|
||||
Last_Init := Stmt;
|
||||
Body_Insert := Nod_2;
|
||||
|
||||
exit;
|
||||
end if;
|
||||
|
||||
Next (Stmt);
|
||||
end loop;
|
||||
end if;
|
||||
end;
|
||||
|
||||
elsif Is_Init_Call (Nod_2, Utyp) then
|
||||
Last_Init := Nod_2;
|
||||
elsif Is_Init_Call (Stmt_2, Init_Typ) then
|
||||
Last_Init := Stmt_2;
|
||||
Body_Insert := Last_Init;
|
||||
end if;
|
||||
|
||||
-- If the object lacks a call to Deep_Initialize, then it must
|
||||
-- have a call to its related type init proc.
|
||||
|
||||
elsif Is_Init_Call (Stmt, Init_Typ) then
|
||||
Last_Init := Stmt;
|
||||
Body_Insert := Last_Init;
|
||||
end if;
|
||||
end if;
|
||||
end Find_Last_Init;
|
||||
|
||||
-- Local variables
|
||||
|
||||
Obj_Id : constant Entity_Id := Defining_Identifier (Decl);
|
||||
Body_Ins : Node_Id;
|
||||
Count_Ins : Node_Id;
|
||||
Fin_Call : Node_Id;
|
||||
Fin_Stmts : List_Id;
|
||||
Inc_Decl : Node_Id;
|
||||
Label : Node_Id;
|
||||
Label_Id : Entity_Id;
|
||||
Obj_Ref : Node_Id;
|
||||
Obj_Typ : Entity_Id;
|
||||
|
||||
-- Start of processing for Process_Object_Declaration
|
||||
|
||||
begin
|
||||
|
@ -2492,7 +2561,7 @@ package body Exp_Ch7 is
|
|||
-- initialized via an aggregate, then the counter must be inserted
|
||||
-- after the last aggregate assignment.
|
||||
|
||||
if Ekind (Obj_Id) = E_Variable
|
||||
if Ekind_In (Obj_Id, E_Constant, E_Variable)
|
||||
and then Present (Last_Aggregate_Assignment (Obj_Id))
|
||||
then
|
||||
Count_Ins := Last_Aggregate_Assignment (Obj_Id);
|
||||
|
@ -2502,7 +2571,7 @@ package body Exp_Ch7 is
|
|||
-- either [Deep_]Initialize or the type specific init proc.
|
||||
|
||||
else
|
||||
Find_Last_Init (Decl, Obj_Typ, Count_Ins, Body_Ins);
|
||||
Find_Last_Init (Decl, Count_Ins, Body_Ins);
|
||||
end if;
|
||||
|
||||
Insert_After (Count_Ins, Inc_Decl);
|
||||
|
@ -2526,7 +2595,7 @@ package body Exp_Ch7 is
|
|||
end if;
|
||||
|
||||
-- Create the associated label with this object, generate:
|
||||
--
|
||||
|
||||
-- L<counter> : label;
|
||||
|
||||
Label_Id :=
|
||||
|
@ -2541,7 +2610,7 @@ package body Exp_Ch7 is
|
|||
Label_Construct => Label));
|
||||
|
||||
-- Create the associated jump with this object, generate:
|
||||
|
||||
--
|
||||
-- when <counter> =>
|
||||
-- goto L<counter>;
|
||||
|
||||
|
@ -2685,7 +2754,8 @@ package body Exp_Ch7 is
|
|||
if Is_Build_In_Place_Function (Func_Id)
|
||||
and then Needs_BIP_Finalization_Master (Func_Id)
|
||||
then
|
||||
Append_To (Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id));
|
||||
Append_To
|
||||
(Fin_Stmts, Build_BIP_Cleanup_Stmts (Func_Id, Obj_Id));
|
||||
end if;
|
||||
end;
|
||||
end if;
|
||||
|
@ -4933,9 +5003,9 @@ package body Exp_Ch7 is
|
|||
-----------------------
|
||||
|
||||
function Make_Adjust_Call
|
||||
(Obj_Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
For_Parent : Boolean := False) return Node_Id
|
||||
(Obj_Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Skip_Self : Boolean := False) return Node_Id
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (Obj_Ref);
|
||||
Adj_Id : Entity_Id := Empty;
|
||||
|
@ -4972,11 +5042,13 @@ package body Exp_Ch7 is
|
|||
Ref := Unchecked_Convert_To (Utyp, Ref);
|
||||
end if;
|
||||
|
||||
-- Select the appropriate version of adjust
|
||||
|
||||
if For_Parent then
|
||||
if Skip_Self then
|
||||
if Has_Controlled_Component (Utyp) then
|
||||
Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
|
||||
if Is_Tagged_Type (Utyp) then
|
||||
Adj_Id := Find_Prim_Op (Utyp, TSS_Deep_Adjust);
|
||||
else
|
||||
Adj_Id := TSS (Utyp, TSS_Deep_Adjust);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Class-wide types, interfaces and types with controlled components
|
||||
|
@ -5027,7 +5099,11 @@ package body Exp_Ch7 is
|
|||
Ref := Convert_View (Adj_Id, Ref);
|
||||
end if;
|
||||
|
||||
return Make_Call (Loc, Adj_Id, New_Copy_Tree (Ref), For_Parent);
|
||||
return
|
||||
Make_Call (Loc,
|
||||
Proc_Id => Adj_Id,
|
||||
Param => New_Copy_Tree (Ref),
|
||||
Skip_Self => Skip_Self);
|
||||
else
|
||||
return Empty;
|
||||
end if;
|
||||
|
@ -5075,19 +5151,18 @@ package body Exp_Ch7 is
|
|||
---------------
|
||||
|
||||
function Make_Call
|
||||
(Loc : Source_Ptr;
|
||||
Proc_Id : Entity_Id;
|
||||
Param : Node_Id;
|
||||
For_Parent : Boolean := False) return Node_Id
|
||||
(Loc : Source_Ptr;
|
||||
Proc_Id : Entity_Id;
|
||||
Param : Node_Id;
|
||||
Skip_Self : Boolean := False) return Node_Id
|
||||
is
|
||||
Params : constant List_Id := New_List (Param);
|
||||
|
||||
begin
|
||||
-- When creating a call to Deep_Finalize for a _parent field of a
|
||||
-- derived type, disable the invocation of the nested Finalize by giving
|
||||
-- the corresponding flag a False value.
|
||||
-- Do not apply the controlled action to the object itself by signaling
|
||||
-- the related routine to avoid self.
|
||||
|
||||
if For_Parent then
|
||||
if Skip_Self then
|
||||
Append_To (Params, New_Occurrence_Of (Standard_False, Loc));
|
||||
end if;
|
||||
|
||||
|
@ -6307,13 +6382,13 @@ package body Exp_Ch7 is
|
|||
if Needs_Finalization (Par_Typ) then
|
||||
Call :=
|
||||
Make_Adjust_Call
|
||||
(Obj_Ref =>
|
||||
(Obj_Ref =>
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => Make_Identifier (Loc, Name_V),
|
||||
Selector_Name =>
|
||||
Make_Identifier (Loc, Name_uParent)),
|
||||
Typ => Par_Typ,
|
||||
For_Parent => True);
|
||||
Typ => Par_Typ,
|
||||
Skip_Self => True);
|
||||
|
||||
-- Generate:
|
||||
-- Deep_Adjust (V._parent, False); -- No_Except_Propagat
|
||||
|
@ -6882,13 +6957,13 @@ package body Exp_Ch7 is
|
|||
if Needs_Finalization (Par_Typ) then
|
||||
Call :=
|
||||
Make_Final_Call
|
||||
(Obj_Ref =>
|
||||
(Obj_Ref =>
|
||||
Make_Selected_Component (Loc,
|
||||
Prefix => Make_Identifier (Loc, Name_V),
|
||||
Selector_Name =>
|
||||
Make_Identifier (Loc, Name_uParent)),
|
||||
Typ => Par_Typ,
|
||||
For_Parent => True);
|
||||
Typ => Par_Typ,
|
||||
Skip_Self => True);
|
||||
|
||||
-- Generate:
|
||||
-- Deep_Finalize (V._parent, False); -- No_Except_Propag
|
||||
|
@ -7118,9 +7193,9 @@ package body Exp_Ch7 is
|
|||
----------------------
|
||||
|
||||
function Make_Final_Call
|
||||
(Obj_Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
For_Parent : Boolean := False) return Node_Id
|
||||
(Obj_Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Skip_Self : Boolean := False) return Node_Id
|
||||
is
|
||||
Loc : constant Source_Ptr := Sloc (Obj_Ref);
|
||||
Atyp : Entity_Id;
|
||||
|
@ -7203,11 +7278,13 @@ package body Exp_Ch7 is
|
|||
Set_Assignment_OK (Ref);
|
||||
end if;
|
||||
|
||||
-- Select the appropriate version of Finalize
|
||||
|
||||
if For_Parent then
|
||||
if Skip_Self then
|
||||
if Has_Controlled_Component (Utyp) then
|
||||
Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
|
||||
if Is_Tagged_Type (Utyp) then
|
||||
Fin_Id := Find_Prim_Op (Utyp, TSS_Deep_Finalize);
|
||||
else
|
||||
Fin_Id := TSS (Utyp, TSS_Deep_Finalize);
|
||||
end if;
|
||||
end if;
|
||||
|
||||
-- Class-wide types, interfaces and types with controlled components
|
||||
|
@ -7278,7 +7355,11 @@ package body Exp_Ch7 is
|
|||
Ref := Convert_View (Fin_Id, Ref);
|
||||
end if;
|
||||
|
||||
return Make_Call (Loc, Fin_Id, New_Copy_Tree (Ref), For_Parent);
|
||||
return
|
||||
Make_Call (Loc,
|
||||
Proc_Id => Fin_Id,
|
||||
Param => New_Copy_Tree (Ref),
|
||||
Skip_Self => Skip_Self);
|
||||
else
|
||||
return Empty;
|
||||
end if;
|
||||
|
|
|
@ -162,14 +162,14 @@ package Exp_Ch7 is
|
|||
-- latest extension contains a controlled component.
|
||||
|
||||
function Make_Adjust_Call
|
||||
(Obj_Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
For_Parent : Boolean := False) return Node_Id;
|
||||
(Obj_Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Skip_Self : Boolean := False) return Node_Id;
|
||||
-- Create a call to either Adjust or Deep_Adjust depending on the structure
|
||||
-- of type Typ. Obj_Ref is an expression with no-side effect (not required
|
||||
-- to have been previously analyzed) that references the object to be
|
||||
-- adjusted. Typ is the expected type of Obj_Ref. Flag For_Parent must be
|
||||
-- set when an adjustment call is being created for field _parent.
|
||||
-- adjusted. Typ is the expected type of Obj_Ref. When Skip_Self is set,
|
||||
-- only the components (if any) are adjusted.
|
||||
|
||||
function Make_Attach_Call
|
||||
(Obj_Ref : Node_Id;
|
||||
|
@ -191,15 +191,14 @@ package Exp_Ch7 is
|
|||
-- (System.Finalization_Root.Root_Controlled_Ptr (Obj_Ref));
|
||||
|
||||
function Make_Final_Call
|
||||
(Obj_Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
For_Parent : Boolean := False) return Node_Id;
|
||||
(Obj_Ref : Node_Id;
|
||||
Typ : Entity_Id;
|
||||
Skip_Self : Boolean := False) return Node_Id;
|
||||
-- Create a call to either Finalize or Deep_Finalize depending on the
|
||||
-- structure of type Typ. Obj_Ref is an expression (with no-side effect and
|
||||
-- is not required to have been previously analyzed) that references the
|
||||
-- object to be finalized. Typ is the expected type of Obj_Ref. Flag For_
|
||||
-- Parent must be set when a finalization call is being created for field
|
||||
-- _parent.
|
||||
-- structure of type Typ. Obj_Ref is an expression (with no-side effect
|
||||
-- and is not required to have been previously analyzed) that references
|
||||
-- the object to be finalized. Typ is the expected type of Obj_Ref. When
|
||||
-- Skip_Self is set, only the components (if any) are finalized.
|
||||
|
||||
procedure Make_Finalize_Address_Body (Typ : Entity_Id);
|
||||
-- Create the body of TSS routine Finalize_Address if Typ is controlled and
|
||||
|
@ -300,7 +299,12 @@ package Exp_Ch7 is
|
|||
procedure Store_After_Actions_In_Scope (L : List_Id);
|
||||
-- Prepend the list L of actions to the beginning of the after-actions
|
||||
-- stored in the top of the scope stack (also analyzes these actions).
|
||||
-- Why prepend rather than append ???
|
||||
--
|
||||
-- Note that we are prepending here rather than appending. This means that
|
||||
-- if several calls are made to this procedure for the same scope, the
|
||||
-- actions will be executed in reverse order of the calls (actions for the
|
||||
-- last call executed first). Within the list L for a single call, the
|
||||
-- actions are executed in the order in which they appear in this list.
|
||||
|
||||
procedure Store_Cleanup_Actions_In_Scope (L : List_Id);
|
||||
-- Prepend the list L of actions to the beginning of the cleanup-actions
|
||||
|
|
|
@ -2436,10 +2436,11 @@ package body Sem_Ch9 is
|
|||
|
||||
-- AI05-0225: the target protected object of a requeue must be a
|
||||
-- variable. This is a binding interpretation that applies to all
|
||||
-- versions of the language.
|
||||
-- versions of the language. Note that the subprogram does not have
|
||||
-- to be a protected operation: it can be an primitive implemented
|
||||
-- by entry with a formal that is a protected interface.
|
||||
|
||||
if Present (Target_Obj)
|
||||
and then Ekind (Scope (Entry_Id)) in Protected_Kind
|
||||
and then not Is_Variable (Target_Obj)
|
||||
then
|
||||
Error_Msg_N
|
||||
|
|
Loading…
Reference in New Issue