+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
-- Entry_Component Node11
-- Enumeration_Pos Uint11
-- Generic_Homonym Node11
- -- Last_Aggregate_Assignment Node11
-- Protected_Body_Subprogram Node11
-- Block_Node Node11
-- Subprograms_For_Type Node29
-- Corresponding_Equality Node30
+ -- Last_Aggregate_Assignment Node30
-- Static_Initialization Node30
-- Thunk_Entity Node31
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
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
when E_Generic_Package =>
Write_Str ("Generic_Homonym");
- when E_Variable =>
- Write_Str ("Last_Aggregate_Assignment");
-
when E_Function |
E_Procedure |
E_Entry |
when E_Function =>
Write_Str ("Corresponding_Equality");
+ when E_Constant |
+ E_Variable =>
+ Write_Str ("Last_Aggregate_Assignment");
+
when E_Procedure =>
Write_Str ("Static_Initialization");
-- 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
-- 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)
-- Hiding_Loop_Variable (Node8)
-- Current_Value (Node9)
-- Encapsulating_State (Node10)
- -- Last_Aggregate_Assignment (Node11)
-- Esize (Uint12)
-- Extra_Accessibility (Node13)
-- Alignment (Uint14)
-- Related_Type (Node27)
-- Initialization_Statements (Node28)
-- BIP_Initialization_Call (Node29)
+ -- Last_Aggregate_Assignment (Node30)
-- Linker_Section_Pragma (Node33)
-- Contract (Node34)
-- Has_Alignment_Clause (Flag46)
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).
-- 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 --
------------------------------------------------------
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
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)),
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;
----------------------------------
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))),
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).
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.
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 --
-------------------------
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
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
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;
-- 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;
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
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 :=
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.
+
+ -- Deep_Initialize
+
+ Deep_Init := TSS (Init_Typ, TSS_Deep_Initialize);
+
+ -- Primitive Initialize
- if Is_Controlled (Typ) then
- Init := Find_Prim_Op (Typ, Name_Initialize);
+ if Is_Controlled (Init_Typ) then
+ Prim_Init := Find_Prim_Op (Init_Typ, Name_Initialize);
- if Present (Init) then
- Init := Ultimate_Alias (Init);
- end if;
+ 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;
-- 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
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;
- end if;
+ -- Obtain the proper type of the object being initialized
- if Is_Private_Type (Utyp)
- and then Present (Full_View (Utyp))
- then
- Utyp := Full_View (Utyp);
+ 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;
+ Stmt := Next_Suitable_Statement (Decl);
+
-- A limited controlled object initialized by a function call uses
-- the build-in-place machinery to obtain its value.
-- 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))
Next (Stmt);
end loop;
- -- The init procedures are arranged as follows:
-
- -- Object : Controlled_Type;
- -- Controlled_TypeIP (Object);
- -- [[Deep_]Initialize (Object);]
-
- -- where the user-defined initialize may be optional or may appear
- -- inside a block when abort deferral is needed.
+ -- 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:
+
+ -- [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;]
+
+ -- 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);
-
- if Present (Nod_1) then
- Nod_2 := Next_Suitable_Statement (Nod_1);
+ Stmt_2 := Next_Suitable_Statement (Stmt);
- -- The statement following an object declaration is always a
- -- call to the type init proc.
+ -- Check for an optional call to Deep_Initialize which may
+ -- appear within a block depending on whether the object has
+ -- controlled components.
- Last_Init := Nod_1;
- 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.
+ if Present (Stmt_2) then
+ if Nkind (Stmt_2) = N_Block_Statement then
+ Call := Find_Last_Init_In_Block (Stmt_2, Init_Typ);
- Stmt := First (Statements (HSS));
- while Present (Stmt) loop
- if Is_Init_Call (Stmt, Utyp) then
- Last_Init := Stmt;
- Body_Insert := Nod_2;
+ if Present (Call) then
+ Last_Init := Call;
+ Body_Insert := Stmt_2;
+ end if;
- exit;
- end if;
+ elsif Is_Init_Call (Stmt_2, Init_Typ) then
+ Last_Init := Stmt_2;
+ Body_Insert := Last_Init;
+ end if;
- Next (Stmt);
- end loop;
- end if;
- end;
+ -- 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 (Nod_2, Utyp) then
- Last_Init := Nod_2;
- end if;
+ 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
-- 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);
-- 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);
end if;
-- Create the associated label with this object, generate:
- --
+
-- L<counter> : label;
Label_Id :=
Label_Construct => Label));
-- Create the associated jump with this object, generate:
-
+ --
-- when <counter> =>
-- goto L<counter>;
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;
-----------------------
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;
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
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;
---------------
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;
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
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
----------------------
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;
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
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;
-- 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;
-- (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
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
-- 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
projects / platform / upstream / gcc.git / commitdiff