-- Ada 2005 (AI-287): If the component type has tasks then
-- generate the activation chain and master entities (except
-- in case of an allocator because in that case these entities
- -- are generated by Build_Task_Allocate_Block_With_Init_Stmts).
+ -- are generated by Build_Task_Allocate_Block).
declare
Ctype : constant Entity_Id := Etype (Selector);
Init_Stmts := Late_Expansion (Aggr, Typ, Occ);
if Has_Task (Typ) then
- Build_Task_Allocate_Block_With_Init_Stmts (L, Aggr, Init_Stmts);
+ Build_Task_Allocate_Block (L, Aggr, Init_Stmts);
Insert_Actions (Alloc, L);
else
Insert_Actions (Alloc, Init_Stmts);
end if;
end Build_Array_Init_Proc;
+ ----------------------------------
+ -- Build_Default_Initialization --
+ ----------------------------------
+
+ function Build_Default_Initialization
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Obj_Id : Entity_Id;
+ For_CW : Boolean := False;
+ Target_Ref : Node_Id := Empty) return List_Id
+ is
+ Exceptions_OK : constant Boolean :=
+ not Restriction_Active (No_Exception_Propagation);
+ Loc : constant Source_Ptr := Sloc (N);
+
+ function New_Object_Reference return Node_Id;
+ -- Return either a reference to Obj_Id or a dereference of Obj_Id
+
+ --------------------------
+ -- New_Object_Reference --
+ --------------------------
+
+ function New_Object_Reference return Node_Id is
+ Obj_Ref : Node_Id := New_Occurrence_Of (Obj_Id, Loc);
+
+ begin
+ if Nkind (N) = N_Object_Declaration then
+ -- The call to the type init proc or [Deep_]Finalize must not
+ -- freeze the object since the call is internally generated.
+ -- This prevents representation clauses from being rejected.
+ -- Note that the initialization call may be removed if pragma
+ -- Import is encountered or moved to the freeze actions of
+ -- the object if an address clause is encountered.
+
+ Set_Assignment_OK (Obj_Ref);
+ Set_Must_Not_Freeze (Obj_Ref);
+
+ else pragma Assert (Nkind (N) = N_Allocator);
+ Obj_Ref := Make_Explicit_Dereference (Loc, Obj_Ref);
+
+ -- If the designated subtype is unconstrained and the allocator
+ -- specifies a constrained subtype, or such a subtype has been
+ -- created, associate that subtype with the dereference of the
+ -- allocator's access value. This is needed by the expander for
+ -- cases where the access type has a Designated_Storage_Model
+ -- in order to support allocation of a host object of the right
+ -- size for passing to the initialization procedure.
+
+ if not Is_Constrained (Designated_Type (Etype (N)))
+ and then Is_Constrained (Typ)
+ then
+ Set_Actual_Designated_Subtype (Obj_Ref, Typ);
+ end if;
+
+ -- The initialization procedure expects a specific type so.
+ -- if the context is access to class-wide, indicate that the
+ -- object being initialized has the right specific type.
+
+ if For_CW then
+ Obj_Ref := Unchecked_Convert_To (Typ, Obj_Ref);
+ end if;
+ end if;
+
+ return Obj_Ref;
+ end New_Object_Reference;
+
+ -- Local variables
+
+ Comp_Init : List_Id := No_List;
+ Fin_Block : Node_Id;
+ Fin_Call : Node_Id;
+ Init_Stmts : List_Id := No_List;
+ Obj_Init : Node_Id := Empty;
+ Obj_Ref : Node_Id;
+
+ -- Start of processing for Build_Default_Initialization
+
+ begin
+ -- The expansion performed by this routine is as follows:
+
+ -- begin
+ -- Abort_Defer;
+ -- Type_Init_Proc (Obj);
+
+ -- begin
+ -- [Deep_]Initialize (Obj);
+
+ -- exception
+ -- when others =>
+ -- [Deep_]Finalize (Obj, Self => False);
+ -- raise;
+ -- end;
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ -- Initialize the components of the object
+
+ if Has_Non_Null_Base_Init_Proc (Typ)
+ and then not Initialization_Suppressed (Typ)
+ then
+ -- Do not initialize the components if No_Default_Initialization
+ -- applies as 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
+
+ -- Invoke the type init proc, generate:
+ -- Type_Init_Proc (Obj);
+
+ Obj_Ref := New_Object_Reference;
+
+ if Comes_From_Source (Obj_Id) then
+ Initialization_Warning (Obj_Ref);
+ end if;
+
+ Comp_Init :=
+ Build_Initialization_Call (Loc,
+ Obj_Ref, Typ, Target_Ref => Target_Ref);
+ end if;
+ end if;
+
+ -- Initialize the object, generate:
+ -- [Deep_]Initialize (Obj);
+
+ if Needs_Finalization (Typ) then
+ Obj_Init :=
+ Make_Init_Call
+ (Obj_Ref => New_Object_Reference,
+ Typ => Typ);
+ end if;
+
+ -- Build a special finalization block when both the object and its
+ -- controlled components are to be initialized. The block finalizes
+ -- the components if the object initialization fails. Generate:
+
+ -- begin
+ -- <Obj_Init>
+
+ -- exception
+ -- when others =>
+ -- <Fin_Call>
+ -- raise;
+ -- end;
+
+ if Has_Controlled_Component (Typ)
+ and then Present (Comp_Init)
+ and then Present (Obj_Init)
+ and then Exceptions_OK
+ then
+ Init_Stmts := Comp_Init;
+
+ 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.
+
+ if Legacy_Elaboration_Checks then
+ Set_No_Elaboration_Check (Fin_Call);
+ end if;
+
+ Fin_Block :=
+ 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))))));
+
+ -- Signal the ABE mechanism that the block carries out
+ -- initialization actions.
+
+ Set_Is_Initialization_Block (Fin_Block);
+
+ Append_To (Init_Stmts, Fin_Block);
+ end if;
+
+ -- Otherwise 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
+ Init_Stmts := Comp_Init;
+ end if;
+
+ if Present (Obj_Init) then
+ if No (Init_Stmts) then
+ Init_Stmts := New_List;
+ end if;
+
+ Append_To (Init_Stmts, Obj_Init);
+ end if;
+ end if;
+
+ -- Build an abort block to protect the initialization calls
+
+ if Abort_Allowed
+ and then Present (Comp_Init)
+ and then Present (Obj_Init)
+ then
+ -- Generate:
+ -- Abort_Defer;
+
+ Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
+
+ -- When exceptions are propagated, abort deferral must take place
+ -- in the presence of initialization or finalization exceptions.
+ -- Generate:
+
+ -- begin
+ -- Abort_Defer;
+ -- <Init_Stmts>
+ -- at end
+ -- Abort_Undefer_Direct;
+ -- end;
+
+ if Exceptions_OK then
+ Init_Stmts := New_List (
+ Build_Abort_Undefer_Block (Loc,
+ Stmts => Init_Stmts,
+ Context => N));
+
+ -- Otherwise exceptions are not propagated. Generate:
+
+ -- Abort_Defer;
+ -- <Init_Stmts>
+ -- Abort_Undefer;
+
+ else
+ Append_To (Init_Stmts,
+ Build_Runtime_Call (Loc, RE_Abort_Undefer));
+ end if;
+ end if;
+
+ return Init_Stmts;
+ end Build_Default_Initialization;
+
+ -----------------------------------------
+ -- Build_Default_Simple_Initialization --
+ -----------------------------------------
+
+ function Build_Default_Simple_Initialization
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Obj_Id : Entity_Id) return Node_Id
+ is
+ Loc : constant Source_Ptr := Sloc (N);
+
+ function Build_Equivalent_Aggregate return Node_Id;
+ -- 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.
+
+ function Simple_Initialization_OK (Typ : Entity_Id) return Boolean;
+ -- Determine whether object declaration N with entity Obj_Id if set, or
+ -- object allocation N if Obj_Id is empty, needs simple initialization,
+ -- assuming that it is of type Typ.
+
+ --------------------------------
+ -- Build_Equivalent_Aggregate --
+ --------------------------------
+
+ function Build_Equivalent_Aggregate return Node_Id is
+ Aggr : Node_Id;
+ Comp : Entity_Id;
+ Discr : Elmt_Id;
+ Full_Typ : Entity_Id;
+
+ begin
+ if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
+ Full_Typ := Full_View (Typ);
+ else
+ Full_Typ := Typ;
+ end if;
+
+ -- Only do this transformation for a package entity of a constrained
+ -- record type and if Elaboration_Code is forbidden or undesirable.
+
+ -- If Initialize_Scalars might be active this transformation cannot
+ -- be performed either, because it will lead to different semantics
+ -- or because elaboration code will in fact be created.
+
+ if Ekind (Full_Typ) /= E_Record_Subtype
+ or else not Has_Discriminants (Full_Typ)
+ or else not Is_Constrained (Full_Typ)
+ or else Is_Controlled (Full_Typ)
+ or else Is_Limited_Type (Full_Typ)
+ or else Ekind (Current_Scope) /= E_Package
+ or else not (Is_Preelaborated (Current_Scope)
+ or else Restriction_Active (No_Elaboration_Code))
+ or else not Restriction_Active (No_Initialize_Scalars)
+ then
+ return Empty;
+ end if;
+
+ -- Building a static aggregate is possible if the discriminants
+ -- have static values and the other components have static
+ -- defaults or none.
+
+ Discr := First_Elmt (Discriminant_Constraint (Full_Typ));
+ while Present (Discr) loop
+ if not Is_OK_Static_Expression (Node (Discr)) then
+ return Empty;
+ end if;
+
+ Next_Elmt (Discr);
+ end loop;
+
+ -- Check that initialized components are OK, and that non-
+ -- initialized components do not require a call to their own
+ -- initialization procedure.
+
+ Comp := First_Component (Full_Typ);
+ while Present (Comp) loop
+ if Present (Expression (Parent (Comp)))
+ and then not Is_OK_Static_Expression (Expression (Parent (Comp)))
+ then
+ return Empty;
+
+ elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
+ return Empty;
+
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ -- Everything is static, assemble the aggregate, discriminant
+ -- values first.
+
+ Aggr :=
+ Make_Aggregate (Loc,
+ Expressions => New_List,
+ Component_Associations => New_List);
+ Set_Parent (Aggr, N);
+
+ Discr := First_Elmt (Discriminant_Constraint (Full_Typ));
+ while Present (Discr) loop
+ Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
+ Next_Elmt (Discr);
+ end loop;
+
+ -- Now collect values of initialized components
+
+ Comp := First_Component (Full_Typ);
+ while Present (Comp) loop
+ if Present (Expression (Parent (Comp))) then
+ Append_To (Component_Associations (Aggr),
+ Make_Component_Association (Loc,
+ Choices => New_List (New_Occurrence_Of (Comp, Loc)),
+ Expression => New_Copy_Tree
+ (Expression (Parent (Comp)))));
+ end if;
+
+ Next_Component (Comp);
+ end loop;
+
+ -- Finally, box-initialize remaining components
+
+ Append_To (Component_Associations (Aggr),
+ Make_Component_Association (Loc,
+ Choices => New_List (Make_Others_Choice (Loc)),
+ Expression => Empty));
+ Set_Box_Present (Last (Component_Associations (Aggr)));
+
+ if Typ /= Full_Typ then
+ Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Typ)));
+ Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
+ end if;
+
+ return Aggr;
+ end Build_Equivalent_Aggregate;
+
+ ------------------------------
+ -- Simple_Initialization_OK --
+ ------------------------------
+
+ function Simple_Initialization_OK (Typ : Entity_Id) return Boolean is
+ begin
+ -- Skip internal entities as specified in Einfo
+
+ return
+ not (Present (Obj_Id) and then Is_Internal (Obj_Id))
+ and then
+ Needs_Simple_Initialization
+ (Typ => Typ,
+ Consider_IS =>
+ Initialize_Scalars
+ and then (No (Obj_Id)
+ or else No (Following_Address_Clause (N))));
+ end Simple_Initialization_OK;
+
+ -- Local variables
+
+ Aggr_Init : Node_Id;
+
+ -- Start of processing for Build_Default_Simple_Initialization
+
+ begin
+ if Has_Non_Null_Base_Init_Proc (Typ)
+ and then not Is_Dispatching_Operation (Base_Init_Proc (Typ))
+ and then not Initialization_Suppressed (Typ)
+ then
+ -- Do not initialize the components if No_Default_Initialization
+ -- applies as 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
+ return New_Copy_Tree (Aggr_Init, New_Scope => Current_Scope);
+ end if;
+
+ -- 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.
+
+ Aggr_Init := Build_Equivalent_Aggregate;
+ if Present (Aggr_Init) then
+ return Aggr_Init;
+ end if;
+
+ -- Optimize the default initialization of an array object when
+ -- pragma Initialize_Scalars or Normalize_Scalars is in effect.
+ -- Construct an in-place initialization aggregate which may be
+ -- convert into a fast memset by the backend.
+
+ if Init_Or_Norm_Scalars
+ and then Is_Array_Type (Typ)
+
+ -- The array must lack atomic components because they are
+ -- treated as non-static, and as a result the backend will
+ -- not initialize the memory in one go.
+
+ and then not Has_Atomic_Components (Typ)
+
+ -- The array must not be packed because the invalid values
+ -- in System.Scalar_Values are multiples of Storage_Unit.
+
+ and then not Is_Packed (Typ)
+
+ -- The array must have static non-empty ranges, otherwise
+ -- the backend cannot initialize the memory in one go.
+
+ and then Has_Static_Non_Empty_Array_Bounds (Typ)
+
+ -- The optimization is only relevant for arrays of scalar
+ -- types.
+
+ and then Is_Scalar_Type (Component_Type (Typ))
+
+ -- Similar to regular array initialization using a type
+ -- init proc, predicate checks are not performed because the
+ -- initialization values are intentionally invalid, and may
+ -- violate the predicate.
+
+ and then not Has_Predicates (Component_Type (Typ))
+
+ -- Array default component value takes precedence over
+ -- Init_Or_Norm_Scalars.
+
+ and then No (Find_Aspect (Typ, Aspect_Default_Component_Value))
+
+ -- The component type must have a single initialization value
+
+ and then Simple_Initialization_OK (Component_Type (Typ))
+ then
+ return
+ Get_Simple_Init_Val
+ (Typ => Typ,
+ N => N,
+ Size => (if Known_Esize (Typ)
+ then Esize (Typ)
+ else Uint_0));
+ end if;
+ end if;
+
+ -- Provide a default value if the object needs simple initialization
+
+ elsif Simple_Initialization_OK (Typ) then
+ return
+ Get_Simple_Init_Val
+ (Typ => Typ,
+ N => N,
+ Size => (if Known_Esize (Typ)
+ then Esize (Typ)
+ else Uint_0));
+ end if;
+
+ return Empty;
+ end Build_Default_Simple_Initialization;
+
--------------------------------
-- Build_Discr_Checking_Funcs --
--------------------------------
(Loc : Source_Ptr;
Id_Ref : Node_Id;
Typ : Entity_Id;
- In_Init_Proc : Boolean := False;
+ In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
- Discr_Map : Elist_Id := New_Elmt_List;
- With_Default_Init : Boolean := False;
- Constructor_Ref : Node_Id := Empty;
+ Target_Ref : Node_Id := Empty;
+ Discr_Map : Elist_Id := New_Elmt_List;
+ With_Default_Init : Boolean := False;
+ Constructor_Ref : Node_Id := Empty;
Init_Control_Actual : Entity_Id := Empty) return List_Id
is
Res : constant List_Id := New_List;
-- Local variables
+ A_Type : Entity_Id;
Arg : Node_Id;
Args : List_Id;
Decls : List_Id;
if Has_Task (Full_Type) then
if Restriction_Active (No_Task_Hierarchy) then
Append_To (Args, Make_Integer_Literal (Loc, Library_Task_Level));
+ elsif Present (Target_Ref) then
+ Append_To (Args,
+ New_Occurrence_Of
+ (Master_Id (Base_Type (Root_Type (Etype (Target_Ref)))), Loc));
else
Append_To (Args, Make_Identifier (Loc, Name_uMaster));
end if;
-- This is just a workaround that must be improved later???
if With_Default_Init then
- Append_To (Args,
- Make_String_Literal (Loc,
- Strval => ""));
+ Append_To (Args, Make_String_Literal (Loc, Strval => ""));
else
+ if Present (Enclos_Type) then
+ A_Type := Enclos_Type;
+
+ elsif Present (Target_Ref)
+ and then Nkind (Target_Ref) in N_Indexed_Component
+ | N_Selected_Component
+ then
+ A_Type := Etype (Prefix (Target_Ref));
+
+ else
+ A_Type := Full_Type;
+ end if;
+
Decls :=
- Build_Task_Image_Decls (Loc, Id_Ref, Enclos_Type, In_Init_Proc);
+ Build_Task_Image_Decls (Loc,
+ (if Present (Target_Ref) then Target_Ref else Id_Ref),
+ A_Type,
+ In_Init_Proc);
Decl := Last (Decls);
Append_To (Args,
(if Special_Ret_Obj then Return_Applies_To (Scope (Def_Id)) else Empty);
-- The function if this is a special return object, otherwise Empty
- 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.
-
function Build_Heap_Or_Pool_Allocator
(Temp_Id : Entity_Id;
Temp_Typ : Entity_Id;
function OK_To_Rename_Ref (N : Node_Id) return Boolean;
-- Return True if N denotes an entity with OK_To_Rename set
- --------------------------------
- -- Build_Equivalent_Aggregate --
- --------------------------------
-
- function Build_Equivalent_Aggregate return Boolean is
- Aggr : Node_Id;
- Comp : Entity_Id;
- Discr : Elmt_Id;
- Full_Type : Entity_Id;
-
- begin
- Full_Type := Typ;
-
- if Is_Private_Type (Typ) and then Present (Full_View (Typ)) then
- Full_Type := Full_View (Typ);
- end if;
-
- -- Only perform this transformation if Elaboration_Code is forbidden
- -- or undesirable, and if this is a global entity of a constrained
- -- record type.
-
- -- If Initialize_Scalars might be active this transformation cannot
- -- be performed either, because it will lead to different semantics
- -- or because elaboration code will in fact be created.
-
- if Ekind (Full_Type) /= E_Record_Subtype
- or else not Has_Discriminants (Full_Type)
- or else not Is_Constrained (Full_Type)
- or else Is_Controlled (Full_Type)
- or else Is_Limited_Type (Full_Type)
- or else not Restriction_Active (No_Initialize_Scalars)
- then
- return False;
- end if;
-
- if Ekind (Current_Scope) = E_Package
- 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.
-
- Discr := First_Elmt (Discriminant_Constraint (Full_Type));
- while Present (Discr) loop
- if not Is_OK_Static_Expression (Node (Discr)) then
- return False;
- end if;
-
- Next_Elmt (Discr);
- end loop;
-
- -- Check that initialized components are OK, and that non-
- -- initialized components do not require a call to their own
- -- initialization procedure.
-
- Comp := First_Component (Full_Type);
- while Present (Comp) loop
- if Present (Expression (Parent (Comp)))
- and then
- not Is_OK_Static_Expression (Expression (Parent (Comp)))
- then
- return False;
-
- elsif Has_Non_Null_Base_Init_Proc (Etype (Comp)) then
- return False;
-
- end if;
-
- Next_Component (Comp);
- end loop;
-
- -- Everything is static, assemble the aggregate, discriminant
- -- values first.
-
- Aggr :=
- Make_Aggregate (Loc,
- Expressions => New_List,
- Component_Associations => New_List);
-
- Discr := First_Elmt (Discriminant_Constraint (Full_Type));
- while Present (Discr) loop
- Append_To (Expressions (Aggr), New_Copy (Node (Discr)));
- Next_Elmt (Discr);
- end loop;
-
- -- Now collect values of initialized components
-
- Comp := First_Component (Full_Type);
- while Present (Comp) loop
- if Present (Expression (Parent (Comp))) then
- Append_To (Component_Associations (Aggr),
- Make_Component_Association (Loc,
- Choices => New_List (New_Occurrence_Of (Comp, Loc)),
- Expression => New_Copy_Tree
- (Expression (Parent (Comp)))));
- end if;
-
- Next_Component (Comp);
- end loop;
-
- -- Finally, box-initialize remaining components
-
- Append_To (Component_Associations (Aggr),
- Make_Component_Association (Loc,
- Choices => New_List (Make_Others_Choice (Loc)),
- Expression => Empty));
- Set_Box_Present (Last (Component_Associations (Aggr)));
- Set_Expression (N, Aggr);
-
- if Typ /= Full_Type then
- Analyze_And_Resolve (Aggr, Full_View (Base_Type (Full_Type)));
- Rewrite (Aggr, Unchecked_Convert_To (Typ, Aggr));
- Analyze_And_Resolve (Aggr, Typ);
- else
- Analyze_And_Resolve (Aggr, Full_Type);
- end if;
-
- return True;
-
- else
- return False;
- end if;
- end Build_Equivalent_Aggregate;
-
----------------------------------
-- Build_Heap_Or_Pool_Allocator --
----------------------------------
-------------------------------
procedure Default_Initialize_Object (After : Node_Id) is
- Exceptions_OK : constant Boolean :=
- not Restriction_Active (No_Exception_Propagation);
-
- function New_Object_Reference return Node_Id;
- -- Return a new reference to Def_Id with attributes Assignment_OK and
- -- Must_Not_Freeze already set.
-
- function Simple_Initialization_OK
- (Init_Typ : Entity_Id) return Boolean;
- -- Determine whether object declaration N with entity Def_Id needs
- -- simple initialization, assuming that it is of type Init_Typ.
-
- --------------------------
- -- 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;
-
- ------------------------------
- -- Simple_Initialization_OK --
- ------------------------------
-
- function Simple_Initialization_OK
- (Init_Typ : Entity_Id) return Boolean
- is
- begin
- -- Skip internal entities as specified in Einfo
-
- return
- not Is_Internal (Def_Id)
- and then Needs_Simple_Initialization
- (Typ => Init_Typ,
- Consider_IS =>
- Initialize_Scalars
- and then No (Following_Address_Clause (N)));
- end Simple_Initialization_OK;
-
- -- Local variables
-
- Aggr_Init : Node_Id;
- Comp_Init : List_Id := No_List;
- Fin_Block : Node_Id;
- Fin_Call : Node_Id;
- Init_Stmts : List_Id := No_List;
- Obj_Init : Node_Id := Empty;
- Obj_Ref : Node_Id;
-
- -- Start of processing for Default_Initialize_Object
+ Init_Expr : Node_Id;
+ Init_Stmts : List_Id;
begin
-- Nothing to do if the object has an initialization expression or
return;
end if;
- -- The expansion performed by this routine is as follows:
-
- -- begin
- -- Abort_Defer;
- -- Type_Init_Proc (Obj);
-
- -- begin
- -- [Deep_]Initialize (Obj);
-
- -- exception
- -- when others =>
- -- [Deep_]Finalize (Obj, Self => False);
- -- raise;
- -- end;
- -- at end
- -- Abort_Undefer_Direct;
- -- end;
-
- -- Initialize the components of the object
-
- if Has_Non_Null_Base_Init_Proc (Typ)
- and then not Initialization_Suppressed (Typ)
- then
- -- Do not initialize the components if No_Default_Initialization
- -- applies as 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;
-
- -- Optimize the default initialization of an array object when
- -- pragma Initialize_Scalars or Normalize_Scalars is in effect.
- -- Construct an in-place initialization aggregate which may be
- -- convert into a fast memset by the backend.
-
- elsif Init_Or_Norm_Scalars
- and then Is_Array_Type (Typ)
-
- -- The array must lack atomic components because they are
- -- treated as non-static, and as a result the backend will
- -- not initialize the memory in one go.
-
- and then not Has_Atomic_Components (Typ)
-
- -- The array must not be packed because the invalid values
- -- in System.Scalar_Values are multiples of Storage_Unit.
-
- and then not Is_Packed (Typ)
-
- -- The array must have static non-empty ranges, otherwise
- -- the backend cannot initialize the memory in one go.
-
- and then Has_Static_Non_Empty_Array_Bounds (Typ)
+ -- First try a simple initialization; if it succeeds, then we just
+ -- set the value as the expression of the declaration and let the
+ -- code generator do the rest.
- -- The optimization is only relevant for arrays of scalar
- -- types.
-
- and then Is_Scalar_Type (Component_Type (Typ))
-
- -- Similar to regular array initialization using a type
- -- init proc, predicate checks are not performed because the
- -- initialization values are intentionally invalid, and may
- -- violate the predicate.
-
- and then not Has_Predicates (Component_Type (Typ))
-
- -- Array default component value takes precedence over
- -- Init_Or_Norm_Scalars.
-
- and then No (Find_Aspect (Typ,
- Aspect_Default_Component_Value))
-
- -- The component type must have a single initialization value
-
- and then Simple_Initialization_OK (Component_Type (Typ))
- then
- Set_Expression (N,
- Get_Simple_Init_Val
- (Typ => Typ,
- N => Obj_Def,
- Size => (if Known_Esize (Def_Id) then Esize (Def_Id)
- else Uint_0)));
-
- Analyze_And_Resolve
- (Expression (N), Typ, Suppress => All_Checks);
-
- -- Otherwise invoke the type init proc, generate:
- -- Type_Init_Proc (Obj);
-
- 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
-
- elsif Simple_Initialization_OK (Typ) then
- Set_Expression (N,
- Get_Simple_Init_Val
- (Typ => Typ,
- N => Obj_Def,
- Size =>
- (if Known_Esize (Def_Id) then Esize (Def_Id) else Uint_0)));
-
- Analyze_And_Resolve (Expression (N), Typ);
- end if;
-
- -- Initialize the object, generate:
- -- [Deep_]Initialize (Obj);
-
- if Needs_Finalization (Typ) then
- Obj_Init :=
- Make_Init_Call
- (Obj_Ref => New_Object_Reference,
- Typ => Typ);
- end if;
+ Init_Expr := Build_Default_Simple_Initialization (N, Typ, Def_Id);
- -- Build a special finalization block when both the object and its
- -- controlled components are to be initialized. The block finalizes
- -- the components if the object initialization fails. Generate:
-
- -- begin
- -- <Obj_Init>
-
- -- exception
- -- when others =>
- -- <Fin_Call>
- -- raise;
- -- end;
-
- if Has_Controlled_Component (Typ)
- and then Present (Comp_Init)
- and then Present (Obj_Init)
- and then Exceptions_OK
- then
- Init_Stmts := Comp_Init;
-
- 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.
-
- if Legacy_Elaboration_Checks then
- Set_No_Elaboration_Check (Fin_Call);
- end if;
-
- Fin_Block :=
- 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))))));
-
- -- Signal the ABE mechanism that the block carries out
- -- initialization actions.
-
- Set_Is_Initialization_Block (Fin_Block);
-
- Append_To (Init_Stmts, Fin_Block);
- end if;
-
- -- Otherwise 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
- Init_Stmts := Comp_Init;
- end if;
-
- if Present (Obj_Init) then
- if No (Init_Stmts) then
- Init_Stmts := New_List;
- end if;
-
- Append_To (Init_Stmts, Obj_Init);
- end if;
+ if Present (Init_Expr) then
+ Set_Expression (N, Init_Expr);
+ Analyze_And_Resolve (Init_Expr, Typ);
+ return;
end if;
- -- Build an abort block to protect the initialization calls
-
- if Abort_Allowed
- and then Present (Comp_Init)
- and then Present (Obj_Init)
- then
- -- Generate:
- -- Abort_Defer;
-
- Prepend_To (Init_Stmts, Build_Runtime_Call (Loc, RE_Abort_Defer));
-
- -- When exceptions are propagated, abort deferral must take place
- -- in the presence of initialization or finalization exceptions.
- -- Generate:
-
- -- begin
- -- Abort_Defer;
- -- <Init_Stmts>
- -- at end
- -- Abort_Undefer_Direct;
- -- end;
+ -- Or else build the fully-fledged initialization if need be
- if Exceptions_OK then
- Init_Stmts := New_List (
- Build_Abort_Undefer_Block (Loc,
- Stmts => Init_Stmts,
- Context => N));
-
- -- Otherwise exceptions are not propagated. Generate:
-
- -- Abort_Defer;
- -- <Init_Stmts>
- -- Abort_Undefer;
-
- else
- Append_To (Init_Stmts,
- Build_Runtime_Call (Loc, RE_Abort_Undefer));
- end if;
- end if;
+ Init_Stmts := Build_Default_Initialization (N, Typ, Def_Id);
-- Insert the whole initialization sequence into the tree. If the
-- object has a delayed freeze, as will be the case when it has
-- Expand routines for chapter 3 constructs
-with Types; use Types;
with Elists; use Elists;
with Exp_Tss; use Exp_Tss;
+with Types; use Types;
with Uintp; use Uintp;
package Exp_Ch3 is
-- checks on the relevant aspects. The wrapper body could be simplified to
-- a null body when expansion is disabled ???
+ function Build_Default_Initialization
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Obj_Id : Entity_Id;
+ For_CW : Boolean := False;
+ Target_Ref : Node_Id := Empty) return List_Id;
+ -- Build the code to default-initialize an object of Typ either declared
+ -- or allocated by node N if this is necessary. In the former case Obj_Id
+ -- is the entity for the object whereas, in the second case, Obj_Id is a
+ -- temporary generated to hold the result of the allocator. For_CW is set
+ -- to True in the second case if this result is of a class-wide type.
+
+ -- Target_Ref is only passed identically to Build_Initialization_Call, so
+ -- its description given for Build_Initialization_Call is also valid here.
+
+ function Build_Default_Simple_Initialization
+ (N : Node_Id;
+ Typ : Entity_Id;
+ Obj_Id : Entity_Id) return Node_Id;
+ -- Try to build an expression to default-initialize an object of Typ either
+ -- declared or allocated by node N if this is necessary. In the former case
+ -- Obj_Id is the entity for the object whereas, in the second case, it must
+ -- be set to Empty.
+
procedure Build_Or_Copy_Discr_Checking_Funcs (N : Node_Id);
-- For each variant component, builds a function that checks whether
-- the component name is consistent with the current discriminants
(Loc : Source_Ptr;
Id_Ref : Node_Id;
Typ : Entity_Id;
- In_Init_Proc : Boolean := False;
+ In_Init_Proc : Boolean := False;
Enclos_Type : Entity_Id := Empty;
- Discr_Map : Elist_Id := New_Elmt_List;
- With_Default_Init : Boolean := False;
- Constructor_Ref : Node_Id := Empty;
+ Target_Ref : Node_Id := Empty;
+ Discr_Map : Elist_Id := New_Elmt_List;
+ With_Default_Init : Boolean := False;
+ Constructor_Ref : Node_Id := Empty;
Init_Control_Actual : Entity_Id := Empty) return List_Id;
-- Builds a call to the initialization procedure for the base type of Typ,
-- passing it the object denoted by Id_Ref, plus additional parameters as
-- appropriate for the type (the _Master, for task types, for example).
-- Loc is the source location for the constructed tree. In_Init_Proc has
-- to be set to True when the call is itself in an init proc in order to
- -- enable the use of discriminals. Enclos_Type is the enclosing type when
- -- initializing a component in an outer init proc, and it is used for
- -- various expansion cases including the case where Typ is a task type
- -- which is an array component, the indexes of the enclosing type are
- -- used to build the string that identifies each task at runtime.
+ -- enable the use of discriminals.
+ --
+ -- Enclos_Type is the enclosing type when initializing a component of a
+ -- composite type, and is used for the case where Typ is a task type of
+ -- an array component: the indices of this enclosing type are then used
+ -- to build the image string that identifies each task at run time.
+ --
+ -- Target_Ref is also used when Typ is a task type if the initialization
+ -- call is to be generated for an allocator. It is either the name of a
+ -- simple assignment whose expression is the allocator, or the defining
+ -- identifier of an object declaration whose initializing expression is
+ -- the allocator, or else the allocator's access type. It is used both
+ -- to build the image string and to pass the task master.
--
-- Discr_Map is used to replace discriminants by their discriminals in
-- expressions used to constrain record components. In the presence of
end if;
-- Actions inserted before:
- -- Temp : constant ptr_T := new T'(Expression);
+ -- Temp : constant PtrT := new T'(Expression);
-- Temp._tag = T'tag; -- when not class-wide
-- [Deep_]Adjust (Temp.all);
else
Build_Allocate_Deallocate_Proc (N, True);
- -- For an access to unconstrained packed array, GIGI needs to see an
- -- expression with a constrained subtype in order to compute the
- -- proper size for the allocator.
+ -- For an access-to-unconstrained-packed-array type, build an
+ -- expression with a constrained subtype in order for the code
+ -- generator to compute the proper size for the allocator.
- if Is_Packed_Array (T)
- and then not Is_Constrained (T)
- then
+ if Is_Packed_Array (T) and then not Is_Constrained (T) then
declare
ConstrT : constant Entity_Id := Make_Temporary (Loc, 'A');
Internal_Exp : constant Node_Id := Relocate_Node (Exp);
------------------------
procedure Expand_N_Allocator (N : Node_Id) is
- Etyp : constant Entity_Id := Etype (Expression (N));
Loc : constant Source_Ptr := Sloc (N);
PtrT : constant Entity_Id := Etype (N);
+ Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
+ Etyp : constant Entity_Id := Etype (Expression (N));
procedure Rewrite_Coextension (N : Node_Id);
-- Static coextensions have the same lifetime as the entity they
-- Local variables
- Dtyp : constant Entity_Id := Available_View (Designated_Type (PtrT));
- Desig : Entity_Id;
- Nod : Node_Id;
- Pool : Entity_Id;
- Rel_Typ : Entity_Id;
- Temp : Entity_Id;
+ Desig : Entity_Id;
+ Init_Expr : Node_Id;
+ Init_Stmts : List_Id;
+ Pool : Entity_Id;
+ Rel_Typ : Entity_Id;
+ Target_Ref : Node_Id;
+ Temp : Entity_Id;
+ Temp_Decl : Node_Id;
-- Start of processing for Expand_N_Allocator
if Nkind (Expression (N)) = N_Qualified_Expression then
Expand_Allocator_Expression (N);
- return;
- end if;
+
+ -- If no initialization is necessary, just create a custom Allocate if
+ -- the context requires it.
+
+ elsif No_Initialization (N) then
+ Build_Allocate_Deallocate_Proc (N, True);
-- If the allocator is for a type which requires initialization, and
-- there is no initial value (i.e. operand is a subtype indication
-- rather than a qualified expression), then we must generate a call to
- -- the initialization routine using an expressions action node:
+ -- the initialization routine:
- -- [Pnnn : constant ptr_T := new (T); Init (Pnnn.all,...); Pnnn]
+ -- Temp : constant PtrT := new T;
+ -- Init (Temp.all,...);
+ -- ... := Temp.all;
- -- Here ptr_T is the pointer type for the allocator, and T is the
- -- subtype of the allocator. A special case arises if the designated
- -- type of the access type is a task or contains tasks. In this case
- -- the call to Init (Temp.all ...) is replaced by code that ensures
- -- that tasks get activated (see Exp_Ch9.Build_Task_Allocate_Block
- -- for details). In addition, if the type T is a task type, then the
- -- first argument to Init must be converted to the task record type.
-
- declare
- T : constant Entity_Id := Etype (Expression (N));
- Args : List_Id;
- Decls : List_Id;
- Decl : Node_Id;
- Discr : Elmt_Id;
- Init : Entity_Id;
- Init_Arg1 : Node_Id;
- Init_Call : Node_Id;
- Temp_Decl : Node_Id;
- Temp_Type : Entity_Id;
+ -- A special case arises if T is a task type or contains tasks. In this
+ -- case the call to Init (Temp.all ...) is replaced by code that ensures
+ -- that tasks get activated (see Build_Task_Allocate_Block for details).
- begin
- -- Apply constraint checks against designated subtype (RM 4.8(10/2))
- -- but ignore the expression if the No_Initialization flag is set.
+ else
+ -- Apply constraint checks against designated subtype (RM 4.8(10/2)).
-- Discriminant checks will be generated by the expansion below.
- if Is_Array_Type (Dtyp) and then not No_Initialization (N) then
+ if Is_Array_Type (Dtyp) then
Apply_Constraint_Check (Expression (N), Dtyp, No_Sliding => True);
if Nkind (Expression (N)) = N_Raise_Constraint_Error then
end if;
end if;
- if No_Initialization (N) then
-
- -- Even though this might be a simple allocation, create a custom
- -- Allocate if the context requires it.
-
- if Present (Finalization_Collection (PtrT)) then
- Build_Allocate_Deallocate_Proc
- (N => N,
- Is_Allocate => True);
- end if;
-
- -- Optimize the default allocation of an array object when pragma
- -- Initialize_Scalars or Normalize_Scalars is in effect. Construct an
- -- in-place initialization aggregate which may be convert into a fast
- -- memset by the backend.
-
- elsif Init_Or_Norm_Scalars
- and then Is_Array_Type (T)
-
- -- The array must lack atomic components because they are treated
- -- as non-static, and as a result the backend will not initialize
- -- the memory in one go.
-
- and then not Has_Atomic_Components (T)
+ -- First try a simple initialization; if it succeeds, then we just
+ -- assign the value to the allocated memory.
- -- The array must not be packed because the invalid values in
- -- System.Scalar_Values are multiples of Storage_Unit.
+ Init_Expr := Build_Default_Simple_Initialization (N, Etyp, Empty);
- and then not Is_Packed (T)
-
- -- The array must have static non-empty ranges, otherwise the
- -- backend cannot initialize the memory in one go.
-
- and then Has_Static_Non_Empty_Array_Bounds (T)
-
- -- The optimization is only relevant for arrays of scalar types
-
- and then Is_Scalar_Type (Component_Type (T))
-
- -- Similar to regular array initialization using a type init proc,
- -- predicate checks are not performed because the initialization
- -- values are intentionally invalid, and may violate the predicate.
+ if Present (Init_Expr) then
+ declare
+ Deref : Node_Id;
+ Stmt : Node_Id;
- and then not Has_Predicates (Component_Type (T))
+ begin
+ -- We set the allocator as analyzed so that when we analyze
+ -- the expression node, we do not get an unwanted recursive
+ -- expansion of the allocator expression.
- -- The component type must have a single initialization value
+ Set_Analyzed (N);
- and then Needs_Simple_Initialization
- (Typ => Component_Type (T),
- Consider_IS => True)
- then
- Set_Analyzed (N);
- Temp := Make_Temporary (Loc, 'P');
+ Temp := Make_Temporary (Loc, 'P');
- -- Generate:
- -- Temp : Ptr_Typ := new ...;
+ -- Generate:
+ -- Temp : constant PtrT := new ...;
- Insert_Action
- (Assoc_Node => N,
- Ins_Action =>
+ Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
+ Constant_Present => True,
Object_Definition => New_Occurrence_Of (PtrT, Loc),
- Expression => Relocate_Node (N)),
- Suppress => All_Checks);
-
- -- Generate:
- -- Temp.all := (others => ...);
+ Expression => Relocate_Node (N));
- Insert_Action
- (Assoc_Node => N,
- Ins_Action =>
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Explicit_Dereference (Loc,
- Prefix => New_Occurrence_Of (Temp, Loc)),
- Expression =>
- Get_Simple_Init_Val
- (Typ => T,
- N => N,
- Size => Esize (Component_Type (T)))),
- Suppress => All_Checks);
-
- Rewrite (N, New_Occurrence_Of (Temp, Loc));
- Analyze_And_Resolve (N, PtrT);
-
- Apply_Predicate_Check (N, Dtyp, Deref => True);
-
- -- Case of no initialization procedure present
-
- elsif not Has_Non_Null_Base_Init_Proc (T) then
-
- -- Case of simple initialization required
+ Insert_Action (N, Temp_Decl, Suppress => All_Checks);
+ Build_Allocate_Deallocate_Proc (Temp_Decl, True);
- if Needs_Simple_Initialization (T) then
- Check_Restriction (No_Default_Initialization, N);
- Rewrite (Expression (N),
- Make_Qualified_Expression (Loc,
- Subtype_Mark => New_Occurrence_Of (T, Loc),
- Expression => Get_Simple_Init_Val (T, N)));
+ -- Generate:
+ -- Temp.all := ...
- Analyze_And_Resolve (Expression (Expression (N)), T);
- Analyze_And_Resolve (Expression (N), T);
- Set_Paren_Count (Expression (Expression (N)), 1);
- Expand_N_Allocator (N);
+ Deref :=
+ Make_Explicit_Dereference (Loc,
+ New_Occurrence_Of (Temp, Loc));
- -- No initialization required
+ if Is_Incomplete_Or_Private_Type (Designated_Type (PtrT)) then
+ Deref := Unchecked_Convert_To (Etype (Init_Expr), Deref);
+ end if;
- else
- Build_Allocate_Deallocate_Proc
- (N => N,
- Is_Allocate => True);
- end if;
+ Stmt :=
+ Make_Assignment_Statement (Loc,
+ Name => Deref,
+ Expression => Init_Expr);
+ Set_Assignment_OK (Name (Stmt));
- -- Case of initialization procedure present, must be called
+ Insert_Action (N, Stmt, Suppress => All_Checks);
+ Rewrite (N, New_Occurrence_Of (Temp, Loc));
+ Analyze_And_Resolve (N, PtrT);
+ end;
- -- NOTE: There is a *huge* amount of code duplication here from
- -- Build_Initialization_Call. We should probably refactor???
+ -- Or else build the fully-fledged initialization if need be
else
- Check_Restriction (No_Default_Initialization, N);
-
- if not Restriction_Active (No_Default_Initialization) then
- Init := Base_Init_Proc (T);
- Nod := N;
- Temp := Make_Temporary (Loc, 'P');
-
- -- Construct argument list for the initialization routine call
-
- Init_Arg1 :=
- Make_Explicit_Dereference (Loc,
- Prefix =>
- New_Occurrence_Of (Temp, Loc));
-
- Set_Assignment_OK (Init_Arg1);
- Temp_Type := PtrT;
+ -- For the task case, pass the Master_Id of the access type as
+ -- the value of the _Master parameter, and _Chain as the value
+ -- of the _Chain parameter (_Chain will be defined as part of
+ -- the generated code for the allocator).
+
+ -- In Ada 2005, the context may be a function that returns an
+ -- anonymous access type. In that case the Master_Id has been
+ -- created when expanding the function declaration.
+
+ if Has_Task (Etyp) then
+ if No (Master_Id (Base_Type (PtrT))) then
+ -- The designated type was an incomplete type, and the
+ -- access type did not get expanded. Salvage it now.
+
+ if Present (Declaration_Node (Base_Type (PtrT))) then
+ Expand_N_Full_Type_Declaration
+ (Declaration_Node (Base_Type (PtrT)));
+
+ -- When the allocator has a subtype indication then a
+ -- constraint is present and an itype has been added by
+ -- Analyze_Allocator as the subtype of this allocator.
+
+ -- If an allocator with constraints is called in the
+ -- return statement of a function returning a general
+ -- access type, then propagate to the itype the master
+ -- of the general access type (since it is the master
+ -- associated with the returned object).
+
+ elsif Is_Itype (PtrT)
+ and then Ekind (Current_Scope) = E_Function
+ and then
+ Ekind (Etype (Current_Scope)) = E_General_Access_Type
+ and then In_Return_Value (N)
+ then
+ Set_Master_Id (PtrT, Master_Id (Etype (Current_Scope)));
- -- The initialization procedure expects a specific type. if the
- -- context is access to class wide, indicate that the object
- -- being allocated has the right specific type.
+ -- The only other possibility is an itype. For this
+ -- case, the master must exist in the context. This is
+ -- the case when the allocator initializes an access
+ -- component in an init-proc.
- if Is_Class_Wide_Type (Dtyp) then
- Init_Arg1 := Unchecked_Convert_To (T, Init_Arg1);
+ else
+ pragma Assert (Is_Itype (PtrT));
+ Build_Master_Renaming (PtrT, N);
+ end if;
end if;
- -- If designated type is a concurrent type or if it is private
- -- type whose definition is a concurrent type, the first
- -- argument in the Init routine has to be unchecked conversion
- -- to the corresponding record type. If the designated type is
- -- a derived type, also convert the argument to its root type.
+ -- If the context of the allocator is a declaration or an
+ -- assignment, we can generate a meaningful image for the
+ -- task even though subsequent assignments might remove the
+ -- connection between task and entity. We build this image
+ -- when the left-hand side is a simple variable, a simple
+ -- indexed assignment or a simple selected component.
- if Is_Concurrent_Type (T) then
- Init_Arg1 :=
- Unchecked_Convert_To (
- Corresponding_Record_Type (T), Init_Arg1);
+ if Nkind (Parent (N)) = N_Object_Declaration then
+ Target_Ref := Defining_Identifier (Parent (N));
- elsif Is_Private_Type (T)
- and then Present (Full_View (T))
- and then Is_Concurrent_Type (Full_View (T))
- then
- Init_Arg1 :=
- Unchecked_Convert_To
- (Corresponding_Record_Type (Full_View (T)), Init_Arg1);
-
- elsif Etype (First_Formal (Init)) /= Base_Type (T) then
+ elsif Nkind (Parent (N)) = N_Assignment_Statement then
declare
- Ftyp : constant Entity_Id := Etype (First_Formal (Init));
+ Nam : constant Node_Id := Name (Parent (N));
begin
- Init_Arg1 := OK_Convert_To (Etype (Ftyp), Init_Arg1);
- Set_Etype (Init_Arg1, Ftyp);
- end;
- end if;
-
- Args := New_List (Init_Arg1);
+ if Is_Entity_Name (Nam) then
+ Target_Ref := Nam;
- -- For the task case, pass the Master_Id of the access type as
- -- the value of the _Master parameter, and _Chain as the value
- -- of the _Chain parameter (_Chain will be defined as part of
- -- the generated code for the allocator).
-
- -- In Ada 2005, the context may be a function that returns an
- -- anonymous access type. In that case the Master_Id has been
- -- created when expanding the function declaration.
-
- if Has_Task (T) then
- if No (Master_Id (Base_Type (PtrT))) then
-
- -- The designated type was an incomplete type, and the
- -- access type did not get expanded. Salvage it now.
-
- if Present (Parent (Base_Type (PtrT))) then
- Expand_N_Full_Type_Declaration
- (Parent (Base_Type (PtrT)));
-
- -- When the allocator has a subtype indication then a
- -- constraint is present and an itype has been added by
- -- Analyze_Allocator as the subtype of this allocator.
-
- -- If an allocator with constraints is called in the
- -- return statement of a function returning a general
- -- access type, then propagate to the itype the master
- -- of the general access type (since it is the master
- -- associated with the returned object).
-
- elsif Is_Itype (PtrT)
- and then Ekind (Current_Scope) = E_Function
- and then Ekind (Etype (Current_Scope))
- = E_General_Access_Type
- and then In_Return_Value (N)
+ elsif Nkind (Nam) in N_Indexed_Component
+ | N_Selected_Component
+ and then Is_Entity_Name (Prefix (Nam))
then
- Set_Master_Id (PtrT,
- Master_Id (Etype (Current_Scope)));
-
- -- The only other possibility is an itype. For this
- -- case, the master must exist in the context. This is
- -- the case when the allocator initializes an access
- -- component in an init-proc.
+ Target_Ref := Nam;
else
- pragma Assert (Is_Itype (PtrT));
- Build_Master_Renaming (PtrT, N);
+ Target_Ref := PtrT;
end if;
- end if;
-
- -- If the context of the allocator is a declaration or an
- -- assignment, we can generate a meaningful image for it,
- -- even though subsequent assignments might remove the
- -- connection between task and entity. We build this image
- -- when the left-hand side is a simple variable, a simple
- -- indexed assignment or a simple selected component.
-
- if Nkind (Parent (N)) = N_Assignment_Statement then
- declare
- Nam : constant Node_Id := Name (Parent (N));
-
- begin
- if Is_Entity_Name (Nam) then
- Decls :=
- Build_Task_Image_Decls
- (Loc,
- New_Occurrence_Of
- (Entity (Nam), Sloc (Nam)), T);
-
- elsif Nkind (Nam) in N_Indexed_Component
- | N_Selected_Component
- and then Is_Entity_Name (Prefix (Nam))
- then
- Decls :=
- Build_Task_Image_Decls
- (Loc, Nam, Etype (Prefix (Nam)));
- else
- Decls := Build_Task_Image_Decls (Loc, T, T);
- end if;
- end;
-
- elsif Nkind (Parent (N)) = N_Object_Declaration then
- Decls :=
- Build_Task_Image_Decls
- (Loc, Defining_Identifier (Parent (N)), T);
-
- else
- Decls := Build_Task_Image_Decls (Loc, T, T);
- end if;
-
- if Restriction_Active (No_Task_Hierarchy) then
- Append_To
- (Args, Make_Integer_Literal (Loc, Library_Task_Level));
- else
- Append_To (Args,
- New_Occurrence_Of
- (Master_Id (Base_Type (Root_Type (PtrT))), Loc));
- end if;
-
- Append_To (Args, Make_Identifier (Loc, Name_uChain));
-
- Decl := Last (Decls);
- Append_To (Args,
- New_Occurrence_Of (Defining_Identifier (Decl), Loc));
+ end;
- -- Has_Task is false, Decls not used
+ -- Otherwise we just pass the access type
else
- Decls := No_List;
+ Target_Ref := PtrT;
end if;
- -- Add discriminants if discriminated type
-
- declare
- Dis : Boolean := False;
- Typ : Entity_Id := T;
-
- begin
- if Has_Discriminants (T) then
- Dis := True;
-
- -- Type may be a private type with no visible discriminants
- -- in which case check full view if in scope, or the
- -- underlying_full_view if dealing with a type whose full
- -- view may be derived from a private type whose own full
- -- view has discriminants.
-
- elsif Is_Private_Type (T) then
- if Present (Full_View (T))
- and then Has_Discriminants (Full_View (T))
- then
- Dis := True;
- Typ := Full_View (T);
-
- elsif Present (Underlying_Full_View (T))
- and then Has_Discriminants (Underlying_Full_View (T))
- then
- Dis := True;
- Typ := Underlying_Full_View (T);
- end if;
- end if;
-
- if Dis then
-
- -- If the allocated object will be constrained by the
- -- default values for discriminants, then build a subtype
- -- with those defaults, and change the allocated subtype
- -- to that. Note that this happens in fewer cases in Ada
- -- 2005 (AI-363).
-
- if not Is_Constrained (Typ)
- and then Present (Discriminant_Default_Value
- (First_Discriminant (Typ)))
- and then (Ada_Version < Ada_2005
- or else not
- Object_Type_Has_Constrained_Partial_View
- (Typ, Current_Scope))
- then
- Typ := Build_Default_Subtype (Typ, N);
- Set_Expression (N, New_Occurrence_Of (Typ, Loc));
- end if;
-
- Discr := First_Elmt (Discriminant_Constraint (Typ));
- while Present (Discr) loop
- Nod := Node (Discr);
- Append (New_Copy_Tree (Node (Discr)), Args);
-
- -- AI-416: when the discriminant constraint is an
- -- anonymous access type make sure an accessibility
- -- check is inserted if necessary (3.10.2(22.q/2))
+ -- Nothing to pass in the non-task case
- if Ada_Version >= Ada_2005
- and then
- Ekind (Etype (Nod)) = E_Anonymous_Access_Type
- and then not
- No_Dynamic_Accessibility_Checks_Enabled (Nod)
- then
- Apply_Accessibility_Check
- (Nod, Typ, Insert_Node => Nod);
- end if;
-
- Next_Elmt (Discr);
- end loop;
- end if;
+ else
+ Target_Ref := Empty;
+ end if;
- -- When the designated subtype is unconstrained and
- -- the allocator specifies a constrained subtype (or
- -- such a subtype has been created, such as above by
- -- Build_Default_Subtype), associate that subtype with
- -- the dereference of the allocator's access value.
- -- This is needed by the expander for cases where the
- -- access type has a Designated_Storage_Model in order
- -- to support allocation of a host object of the right
- -- size for passing to the initialization procedure.
-
- if not Is_Constrained (Dtyp)
- and then Is_Constrained (Typ)
- then
- declare
- Deref : constant Node_Id := Unqual_Conv (Init_Arg1);
+ Temp := Make_Temporary (Loc, 'P');
- begin
- pragma Assert (Nkind (Deref) = N_Explicit_Dereference);
-
- Set_Actual_Designated_Subtype (Deref, Typ);
- end;
- end if;
- end;
+ Init_Stmts :=
+ Build_Default_Initialization (N, Etyp, Temp,
+ For_CW => Is_Class_Wide_Type (Dtyp),
+ Target_Ref => Target_Ref);
+ if Present (Init_Stmts) then
-- We set the allocator as analyzed so that when we analyze
- -- the if expression node, we do not get an unwanted recursive
+ -- the expression node, we do not get an unwanted recursive
-- expansion of the allocator expression.
- Set_Analyzed (N, True);
- Nod := Relocate_Node (N);
-
- -- Here is the transformation:
- -- input: new Ctrl_Typ
- -- output: Temp : constant Ctrl_Typ_Ptr := new Ctrl_Typ;
- -- Ctrl_TypIP (Temp.all, ...);
- -- [Deep_]Initialize (Temp.all);
-
- -- Here Ctrl_Typ_Ptr is the pointer type for the allocator, and
- -- is the subtype of the allocator.
+ Set_Analyzed (N);
Temp_Decl :=
Make_Object_Declaration (Loc,
Defining_Identifier => Temp,
Constant_Present => True,
- Object_Definition => New_Occurrence_Of (Temp_Type, Loc),
- Expression => Nod);
+ Object_Definition => New_Occurrence_Of (PtrT, Loc),
+ Expression => Relocate_Node (N));
- Set_Assignment_OK (Temp_Decl);
Insert_Action (N, Temp_Decl, Suppress => All_Checks);
-
Build_Allocate_Deallocate_Proc (Temp_Decl, True);
-- If the designated type is a task type or contains tasks,
- -- create block to activate created tasks, and insert
- -- declaration for Task_Image variable ahead of call.
+ -- create a specific block to activate the created tasks.
- if Has_Task (T) then
+ if Has_Task (Etyp) then
declare
- L : constant List_Id := New_List;
- Blk : Node_Id;
+ Actions : constant List_Id := New_List;
+
begin
- Build_Task_Allocate_Block (L, Nod, Args);
- Blk := Last (L);
- Insert_List_Before (First (Declarations (Blk)), Decls);
- Insert_Actions (N, L);
+ Build_Task_Allocate_Block
+ (Actions, Relocate_Node (N), Init_Stmts);
+ Insert_Actions (N, Actions, Suppress => All_Checks);
end;
else
- Insert_Action (N,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Init, Loc),
- Parameter_Associations => Args));
- end if;
-
- if Needs_Finalization (T) then
-
- -- Generate:
- -- [Deep_]Initialize (Init_Arg1);
-
- Init_Call :=
- Make_Init_Call
- (Obj_Ref => New_Copy_Tree (Init_Arg1),
- Typ => T);
-
- -- Guard against a missing [Deep_]Initialize when the
- -- designated type was not properly frozen.
-
- if Present (Init_Call) then
- Insert_Action (N, Init_Call);
- end if;
+ Insert_Actions (N, Init_Stmts, Suppress => All_Checks);
end if;
Rewrite (N, New_Occurrence_Of (Temp, Loc));
Prefix => New_Occurrence_Of (Temp, Loc)),
Dtyp));
end if;
- end if;
- end if;
- end;
- -- Ada 2005 (AI-251): If the allocator is for a class-wide interface
- -- object that has been rewritten as a reference, we displace "this"
- -- to reference properly its secondary dispatch table.
+ -- Ada 2005 (AI-251): Displace the pointer to reference the
+ -- record component containing the secondary dispatch table
+ -- of the interface type.
- if Nkind (N) = N_Identifier and then Is_Interface (Dtyp) then
- Displace_Allocator_Pointer (N);
+ if Is_Interface (Dtyp) then
+ Displace_Allocator_Pointer (N);
+ end if;
+
+ -- No initialization required
+
+ else
+ Build_Allocate_Deallocate_Proc (N, True);
+ end if;
+ end if;
end if;
exception
begin
if Might_Have_Tasks (Result_Subt) then
Actions := New_List;
- Build_Task_Allocate_Block_With_Init_Stmts
+ Build_Task_Allocate_Block
(Actions, Allocator, Init_Stmts => New_List (Assign));
Chain := Activation_Chain_Entity (Last (Actions));
else
with Exp_Dbug; use Exp_Dbug;
with Exp_Sel; use Exp_Sel;
with Exp_Smem; use Exp_Smem;
-with Exp_Tss; use Exp_Tss;
with Exp_Util; use Exp_Util;
with Freeze; use Freeze;
with Hostparm;
-------------------------------
procedure Build_Task_Allocate_Block
- (Actions : List_Id;
- N : Node_Id;
- Args : List_Id)
- is
- T : constant Entity_Id := Entity (Expression (N));
- Init : constant Entity_Id := Base_Init_Proc (T);
- Loc : constant Source_Ptr := Sloc (N);
- Chain : constant Entity_Id :=
- Make_Defining_Identifier (Loc, Name_uChain);
- Blkent : constant Entity_Id := Make_Temporary (Loc, 'A');
- Block : Node_Id;
-
- begin
- Block :=
- Make_Block_Statement (Loc,
- Identifier => New_Occurrence_Of (Blkent, Loc),
- Declarations => New_List (
-
- -- _Chain : Activation_Chain;
-
- Make_Object_Declaration (Loc,
- Defining_Identifier => Chain,
- Aliased_Present => True,
- Object_Definition =>
- New_Occurrence_Of (RTE (RE_Activation_Chain), Loc))),
-
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
-
- Statements => New_List (
-
- -- Init (Args);
-
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Init, Loc),
- Parameter_Associations => Args),
-
- -- Activate_Tasks (_Chain);
-
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (RTE (RE_Activate_Tasks), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => New_Occurrence_Of (Chain, Loc),
- Attribute_Name => Name_Unchecked_Access))))),
-
- Has_Created_Identifier => True,
- Is_Task_Allocation_Block => True);
-
- Append_To (Actions,
- Make_Implicit_Label_Declaration (Loc,
- Defining_Identifier => Blkent,
- Label_Construct => Block));
-
- Append_To (Actions, Block);
-
- Set_Activation_Chain_Entity (Block, Chain);
- end Build_Task_Allocate_Block;
-
- -----------------------------------------------
- -- Build_Task_Allocate_Block_With_Init_Stmts --
- -----------------------------------------------
-
- procedure Build_Task_Allocate_Block_With_Init_Stmts
(Actions : List_Id;
N : Node_Id;
Init_Stmts : List_Id)
Append_To (Actions, Block);
Set_Activation_Chain_Entity (Block, Chain);
- end Build_Task_Allocate_Block_With_Init_Stmts;
+ end Build_Task_Allocate_Block;
-----------------------------------
-- Build_Task_Proc_Specification --
-- the start of the statements of the activator.
procedure Build_Task_Allocate_Block
- (Actions : List_Id;
- N : Node_Id;
- Args : List_Id);
+ (Actions : List_Id;
+ N : Node_Id;
+ Init_Stmts : List_Id);
-- This routine is used in the case of allocators where the designated type
-- is a task or contains tasks. In this case, the normal initialize call
-- is replaced by:
-- end;
--
-- begin
- -- Init (Args);
+ -- Init_Stmts;
-- Activate_Tasks (_Chain);
-- at end
-- _Expunge;
-- Master_Id of the access type as the _Master parameter, and _Chain
-- (defined above) as the _Chain parameter.
- procedure Build_Task_Allocate_Block_With_Init_Stmts
- (Actions : List_Id;
- N : Node_Id;
- Init_Stmts : List_Id);
- -- Ada 2005 (AI-287): Similar to previous routine, but used to expand
- -- allocated aggregates with default initialized components. Init_Stmts
- -- contains the list of statements required to initialize the allocated
- -- aggregate. It replaces the call to Init (Args) done by
- -- Build_Task_Allocate_Block. Also used to expand allocators containing
- -- build-in-place function calls.
-
function Build_Wrapper_Spec
(Subp_Id : Entity_Id;
Obj_Typ : Entity_Id;
Expr : Node_Id;
Needs_Fin : Boolean;
Pool_Id : Entity_Id;
- Proc_To_Call : Node_Id := Empty;
+ Proc_To_Call : Node_Id;
Ptr_Typ : Entity_Id;
Use_Secondary_Stack_Pool : Boolean;
Expr := N;
end if;
- -- In certain cases an allocator with a qualified expression may
- -- be relocated and used as the initialization expression of a
- -- temporary:
+ -- In certain cases, an allocator with a qualified expression may be
+ -- relocated and used as the initialization expression of a temporary
+ -- and the analysis of the declaration of this temporary may in turn
+ -- create another temporary:
-- before:
-- Obj : Ptr_Typ := new Desig_Typ'(...);
-- after:
- -- Tmp : Ptr_Typ := new Desig_Typ'(...);
- -- Obj : Ptr_Typ := Tmp;
+ -- Tmp2 : Ptr_Typ := new Desig_Typ'(...);
+ -- [constraint_error when Tmp2...]
+ -- Tmp1 : Ptr_Typ := Tmp2
+ -- Obj : Ptr_Typ := Tmp1;
- -- Since the allocator is always marked as analyzed to avoid infinite
- -- expansion, it will never be processed by this routine given that
- -- the designated type needs finalization actions. Detect this case
- -- and complete the expansion of the allocator.
+ -- Detect this case where we are invoked on Tmp1's declaration by
+ -- recognizing Tmp2 and then proceed to its declaration instead.
if Nkind (Expr) = N_Identifier
and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration
return;
end if;
- -- The allocator may have been rewritten into something else in which
- -- case the expansion performed by this routine does not apply.
-
- if Nkind (Expr) /= N_Allocator then
- return;
- end if;
+ pragma Assert (Nkind (Expr) = N_Allocator);
Ptr_Typ := Base_Type (Etype (Expr));
Proc_To_Call := Procedure_To_Call (Expr);
-- illegal.
if Can_Never_Be_Null (Type_Id) then
- declare
- Not_Null_Check : constant Node_Id :=
- Make_Raise_Constraint_Error (Sloc (E),
- Reason => CE_Null_Not_Allowed);
-
- begin
- if Expander_Active then
- Insert_Action (N, Not_Null_Check);
- Analyze (Not_Null_Check);
+ if Expander_Active then
+ Apply_Compile_Time_Constraint_Error
+ (N, "null value not allowed here??", CE_Null_Not_Allowed);
- elsif Warn_On_Ada_2012_Compatibility then
- Error_Msg_N
- ("null value not allowed here in Ada 2012?y?", E);
- end if;
- end;
+ elsif Warn_On_Ada_2012_Compatibility then
+ Error_Msg_N
+ ("null value not allowed here in Ada 2012?y?", E);
+ end if;
end if;
-- Check for missing initialization. Skip this check if the allocator
projects / thirdparty / gcc.git / commitdiff
