@@ -1493,7 +1493,7 @@ package body Exp_Aggr is
or else Has_Task (Base_Type (Ctype))
then
Append_List_To (Stmts,
- Build_Initialization_Call (Loc,
+ Build_Initialization_Call (N,
Id_Ref => Indexed_Comp,
Typ => Ctype,
With_Default_Init => True));
@@ -2936,7 +2936,7 @@ package body Exp_Aggr is
if not Is_Interface (Init_Typ) then
Append_List_To (L,
- Build_Initialization_Call (Loc,
+ Build_Initialization_Call (N,
Id_Ref => Ref,
Typ => Init_Typ,
In_Init_Proc => Within_Init_Proc,
@@ -2971,7 +2971,7 @@ package body Exp_Aggr is
Set_Assignment_OK (Ref);
Append_List_To (L,
- Build_Initialization_Call (Loc,
+ Build_Initialization_Call (N,
Id_Ref => Ref,
Typ => Init_Typ,
In_Init_Proc => Within_Init_Proc,
@@ -3148,7 +3148,7 @@ package body Exp_Aggr is
if Is_CPP_Constructor_Call (Expression (Comp)) then
Append_List_To (L,
- Build_Initialization_Call (Loc,
+ Build_Initialization_Call (N,
Id_Ref =>
Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
@@ -3217,7 +3217,7 @@ package body Exp_Aggr is
end;
Append_List_To (L,
- Build_Initialization_Call (Loc,
+ Build_Initialization_Call (N,
Id_Ref => Make_Selected_Component (Loc,
Prefix => New_Copy_Tree (Target),
Selector_Name =>
@@ -3747,8 +3747,8 @@ package body Exp_Aggr is
Param := First (Parameter_Associations (Stmt));
Insert_Actions
(Stmt,
- Build_Initialization_Call
- (Sloc (N), New_Copy_Tree (Param), Etype (Param)));
+ Build_Initialization_Call (N,
+ New_Copy_Tree (Param), Etype (Param)));
end if;
Next (Stmt);
@@ -9279,13 +9279,11 @@ package body Exp_Aggr is
Present (Variant_Part (Component_List (Type_Definition (Decl))))
and then Nkind (N) /= N_Extension_Aggregate
then
-
-- Call init proc to set discriminants.
-- There should eventually be a special procedure for this ???
Ref := New_Occurrence_Of (Defining_Identifier (N), Loc);
- Insert_Actions_After (N,
- Build_Initialization_Call (Sloc (N), Ref, Typ));
+ Insert_Actions_After (N, Build_Initialization_Call (N, Ref, Typ));
end if;
end Initialize_Discriminants;
@@ -699,7 +699,7 @@ package body Exp_Ch3 is
Clean_Task_Names (Comp_Type, Proc_Id);
return
Build_Initialization_Call
- (Loc => Loc,
+ (N => Nod,
Id_Ref => Comp,
Typ => Comp_Type,
In_Init_Proc => True,
@@ -1080,7 +1080,7 @@ package body Exp_Ch3 is
end if;
Comp_Init :=
- Build_Initialization_Call (Loc,
+ Build_Initialization_Call (N,
Obj_Ref, Typ, Target_Ref => Target_Ref);
end if;
end if;
@@ -2013,7 +2013,7 @@ package body Exp_Ch3 is
-- end;
function Build_Initialization_Call
- (Loc : Source_Ptr;
+ (N : Node_Id;
Id_Ref : Node_Id;
Typ : Entity_Id;
In_Init_Proc : Boolean := False;
@@ -2024,7 +2024,8 @@ package body Exp_Ch3 is
Constructor_Ref : Node_Id := Empty;
Init_Control_Actual : Entity_Id := Empty) return List_Id
is
- Res : constant List_Id := New_List;
+ Loc : constant Source_Ptr := Sloc (N);
+ Res : constant List_Id := New_List;
Full_Type : Entity_Id;
@@ -2322,6 +2323,24 @@ package body Exp_Ch3 is
-- Add discriminant values if discriminants are present
if Has_Discriminants (Full_Init_Type) then
+ -- If an 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 (AI95-0363).
+
+ if Nkind (N) = N_Allocator
+ and then not Is_Constrained (Full_Type)
+ and then
+ Present
+ (Discriminant_Default_Value (First_Discriminant (Full_Type)))
+ and then (Ada_Version < Ada_2005
+ or else not Object_Type_Has_Constrained_Partial_View
+ (Full_Type, Current_Scope))
+ then
+ Full_Type := Build_Default_Subtype (Full_Type, N);
+ Set_Expression (N, New_Occurrence_Of (Full_Type, Loc));
+ end if;
+
Discr := First_Discriminant (Full_Init_Type);
while Present (Discr) loop
@@ -3715,7 +3734,7 @@ package body Exp_Ch3 is
if Is_CPP_Constructor_Call (Expression (Decl)) then
Actions :=
Build_Initialization_Call
- (Comp_Loc,
+ (Decl,
Id_Ref =>
Make_Selected_Component (Comp_Loc,
Prefix =>
@@ -3857,7 +3876,7 @@ package body Exp_Ch3 is
Init_Call_Stmts :=
Build_Initialization_Call
- (Comp_Loc,
+ (Decl,
Make_Selected_Component (Comp_Loc,
Prefix =>
Make_Identifier (Comp_Loc, Name_uInit),
@@ -4082,7 +4101,7 @@ package body Exp_Ch3 is
Append_List_To (Late_Stmts,
Build_Initialization_Call
- (Loc => Parent_Loc,
+ (N => Parent (Parent_Id),
Id_Ref =>
Make_Selected_Component (Parent_Loc,
Prefix => Make_Identifier
@@ -4113,7 +4132,7 @@ package body Exp_Ch3 is
elsif Has_Non_Null_Base_Init_Proc (Typ) then
Append_List_To (Late_Stmts,
- Build_Initialization_Call (Comp_Loc,
+ Build_Initialization_Call (Decl,
Make_Selected_Component (Comp_Loc,
Prefix =>
Make_Identifier (Comp_Loc, Name_uInit),
@@ -8099,7 +8118,7 @@ package body Exp_Ch3 is
Set_Assignment_OK (Id_Ref);
Insert_Actions_After (Init_After,
- Build_Initialization_Call (Loc, Id_Ref, Typ,
+ Build_Initialization_Call (N, Id_Ref, Typ,
Constructor_Ref => Expr));
-- We remove here the original call to the constructor
@@ -92,7 +92,7 @@ package Exp_Ch3 is
-- derived type; no new subprograms are constructed in this case.
function Build_Initialization_Call
- (Loc : Source_Ptr;
+ (N : Node_Id;
Id_Ref : Node_Id;
Typ : Entity_Id;
In_Init_Proc : Boolean := False;
@@ -105,7 +105,7 @@ package Exp_Ch3 is
-- 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
+ -- N is the construct for which the call is to be built. 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.
--
@@ -9510,7 +9510,7 @@ package body Exp_Ch6 is
Insert_Action (Allocator, Tmp_Obj);
Insert_List_After_And_Analyze (Tmp_Obj,
- Build_Initialization_Call (Loc,
+ Build_Initialization_Call (Allocator,
Id_Ref =>
Make_Explicit_Dereference (Loc,
Prefix => New_Occurrence_Of (Return_Obj_Access, Loc)),
From: Eric Botcazou <ebotcazou@adacore.com> The allocation strategy for objects of a discriminated type with defaulted discriminants is not the same when the allocation is dynamic as when it is static (i.e a declaration): in the former case, the compiler allocates the default size whereas, in the latter case, it allocates the maximum size. This restores the default size, which was dropped during the refactoring. gcc/ada/ * exp_aggr.adb (Build_Array_Aggr_Code): Pass N in the call to Build_Initialization_Call. (Build_Record_Aggr_Code): Likewise. (Convert_Aggr_In_Object_Decl): Likewise. (Initialize_Discriminants): Likewise. * exp_ch3.ads (Build_Initialization_Call): Replace Loc witn N. * exp_ch3.adb (Build_Array_Init_Proc): Pass N in the call to Build_Initialization_Call. (Build_Default_Initialization): Likewise. (Expand_N_Object_Declaration): Likewise. (Build_Initialization_Call): Replace Loc witn N parameter and add Loc local variable. Build a default subtype for an allocator of a discriminated type with defaulted discriminants. (Build_Record_Init_Proc): Pass the declaration of components in the call to Build_Initialization_Call. * exp_ch6.adb (Make_CPP_Constructor_Call_In_Allocator): Pass the allocator in the call to Build_Initialization_Call. Tested on x86_64-pc-linux-gnu, committed on master. --- gcc/ada/exp_aggr.adb | 18 ++++++++---------- gcc/ada/exp_ch3.adb | 37 ++++++++++++++++++++++++++++--------- gcc/ada/exp_ch3.ads | 4 ++-- gcc/ada/exp_ch6.adb | 2 +- 4 files changed, 39 insertions(+), 22 deletions(-)