@@ -3192,7 +3192,7 @@ package body Exp_Aggr is
-- 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);
@@ -3567,7 +3567,7 @@ package body Exp_Aggr is
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);
@@ -962,6 +962,524 @@ package body Exp_Ch3 is
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 --
--------------------------------
@@ -1498,11 +2016,12 @@ package body Exp_Ch3 is
(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;
@@ -1618,6 +2137,7 @@ package body Exp_Ch3 is
-- Local variables
+ A_Type : Entity_Id;
Arg : Node_Id;
Args : List_Id;
Decls : List_Id;
@@ -1729,6 +2249,10 @@ package body Exp_Ch3 is
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;
@@ -1745,13 +2269,27 @@ package body Exp_Ch3 is
-- 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,
@@ -6208,11 +6746,6 @@ package body Exp_Ch3 is
(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;
@@ -6317,132 +6850,6 @@ package body Exp_Ch3 is
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 --
----------------------------------
@@ -6768,69 +7175,8 @@ package body Exp_Ch3 is
-------------------------------
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
@@ -6861,266 +7207,21 @@ package body Exp_Ch3 is
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
@@ -25,9 +25,9 @@
-- 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
@@ -57,6 +57,30 @@ 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
@@ -71,22 +95,31 @@ package Exp_Ch3 is
(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
@@ -691,7 +691,7 @@ package body Exp_Ch4 is
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);
@@ -1043,13 +1043,11 @@ package body Exp_Ch4 is
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);
@@ -4122,9 +4120,10 @@ package body Exp_Ch4 is
------------------------
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
@@ -4284,12 +4283,14 @@ package body Exp_Ch4 is
-- 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
@@ -4620,42 +4621,31 @@ package body Exp_Ch4 is
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
@@ -4665,456 +4655,190 @@ package body Exp_Ch4 is
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));
@@ -5139,16 +4863,21 @@ package body Exp_Ch4 is
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
@@ -8481,7 +8481,7 @@ package body Exp_Ch6 is
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
@@ -39,7 +39,6 @@ with Exp_Ch11; use Exp_Ch11;
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;
@@ -4796,70 +4795,6 @@ package body Exp_Ch9 is
-------------------------------
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)
@@ -4906,7 +4841,7 @@ package body Exp_Ch9 is
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 --
@@ -119,9 +119,9 @@ package Exp_Ch9 is
-- 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:
@@ -136,7 +136,7 @@ package Exp_Ch9 is
-- end;
--
-- begin
- -- Init (Args);
+ -- Init_Stmts;
-- Activate_Tasks (_Chain);
-- at end
-- _Expunge;
@@ -150,17 +150,6 @@ package Exp_Ch9 is
-- 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;
@@ -820,7 +820,7 @@ package body Exp_Util is
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;
@@ -841,21 +841,22 @@ package body Exp_Util is
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
@@ -865,12 +866,7 @@ package body Exp_Util is
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);
@@ -718,21 +718,14 @@ package body Sem_Ch4 is
-- 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
From: Eric Botcazou <ebotcazou@adacore.com> As written down in a comment, "There is a *huge* amount of code duplication" in the implementation of default initializaion for objects in the front-end, between the (static) declaration case and the dynamic allocation case. This change factors out the implementation of the (static) declaration case and uses it for the dynamic allocation case, with the following benefits: 1. getting rid of the duplication and reducing total line count, 2. bringing optimizations implemented for the (static) declaration case to the dynamic allocation case, 3. performing the missing abort deferral prescribed by RM 9.8(9) in the dynamic allocation case. gcc/ada/ * exp_aggr.adb (Build_Record_Aggr_Code): Replace reference to Build_Task_Allocate_Block_With_Init_Stmts in comment with reference to Build_Task_Allocate_Block. (Convert_Aggr_In_Allocator): Likewise for the call in the code. * exp_ch6.adb (Make_Build_In_Place_Call_In_Allocator): Likewise. * exp_ch3.ads: Alphabetize clauses. (Build_Default_Initialization): New function declaration. (Build_Default_Simple_Initialization): Likewise. (Build_Initialization_Call): Add Target_Ref parameter with default. * exp_ch3.adb (Build_Default_Initialization): New function extracted from... (Build_Default_Simple_Initialization): Likewise. (Build_Initialization_Call): Add Target_Ref parameter with default. (Expand_N_Object_Declaration): ...here. (Default_Initialize_Object): Call Build_Default_Initialization and Build_Default_Simple_Initialization. * exp_ch4.adb (Expand_Allocator_Expression): Minor comment tweaks. (Expand_N_Allocator): Call Build_Default_Initialization and Build_Default_Simple_Initialization to implement the default initialization of the allocated object. * exp_ch9.ads (Build_Task_Allocate_Block): Delete. (Build_Task_Allocate_Block_With_Init_Stmts): Rename into... (Build_Task_Allocate_Block): ...this. * exp_ch9.adb: Remove clauses for Exp_Tss. (Build_Task_Allocate_Block): Delete. (Build_Task_Allocate_Block_With_Init_Stmts): Rename into... (Build_Task_Allocate_Block): ...this. * exp_util.adb (Build_Allocate_Deallocate_Proc): Remove unnecessary initialization expression, adjust commentary and replace early exit with assertion. * sem_ch4.adb (Analyze_Allocator): In the null-exclusion case, call Apply_Compile_Time_Constraint_Error to insert the raise. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 4 +- gcc/ada/exp_ch3.adb | 1015 +++++++++++++++++++++++------------------- gcc/ada/exp_ch3.ads | 53 ++- gcc/ada/exp_ch4.adb | 605 +++++++------------------ gcc/ada/exp_ch6.adb | 2 +- gcc/ada/exp_ch9.adb | 67 +-- gcc/ada/exp_ch9.ads | 19 +- gcc/ada/exp_util.adb | 28 +- gcc/ada/sem_ch4.adb | 21 +- 9 files changed, 795 insertions(+), 1019 deletions(-)