From 062626502fd5d56cd19c5e20c19f2d7cc2c03986 Mon Sep 17 00:00:00 2001
From: Eric Botcazou <ebotcazou@adacore.com>
Date: Mon, 12 Feb 2024 15:23:41 +0100
Subject: [PATCH] ada: Restore default size for dynamic allocations of
discriminated type
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.
---
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(-)
diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb
index 86f304e90bba..a4e4d81f0a8f 100644
--- a/gcc/ada/exp_aggr.adb
+++ b/gcc/ada/exp_aggr.adb
@@ -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;
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 9109d5926905..13a0c8e7500f 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -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
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index 095d39394334..a8018d8dff30 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -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.
--
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index de75bd2fa924..a8a70a5759dc 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -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)),
--
GitLab