From: Denis Mazzucato <[email protected]>
Constructor prologues now call the same routine as initialization procedures to
build component assignments.
gcc/ada/ChangeLog:
* exp_ch3.adb (Build_Record_Init_Proc): Move Build_Assignment to
Build_Component_Assignment in Exp_Util for a more general use.
* exp_ch6.adb (Prepend_Constructor_Procedure_Prologue): refactor using
Build_Component_Assignment.
* exp_util.adb (Build_Component_Assignment): Logic to build component
assignments for initialization procedures and constructor prologues.
* exp_util.ads (Build_Component_Assignment): Likewise.
* sem_ch5.adb (Analyze_Assignment): Revert back changes from previous
attempt to fix assignments of limited types in constructor prologues,
the use of Build_Component_Assignment makes those changes unnecessary.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_ch3.adb | 215 +++++++++++++------------------------------
gcc/ada/exp_ch6.adb | 41 ++++-----
gcc/ada/exp_util.adb | 127 +++++++++++++++++++++++++
gcc/ada/exp_util.ads | 21 +++++
gcc/ada/sem_ch5.adb | 6 +-
5 files changed, 232 insertions(+), 178 deletions(-)
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index db0a32e4681..13cf7bad88c 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -2752,15 +2752,6 @@ package body Exp_Ch3 is
Init_Control_Formal : Entity_Id := Empty; -- set in Build_Init_Statements
Has_Late_Init_Comp : Boolean := False; -- set in Build_Init_Statements
- function Build_Assignment
- (Id : Entity_Id;
- Default : Node_Id) return List_Id;
- -- Build an assignment statement that assigns the default expression to
- -- its corresponding record component if defined. The left-hand side of
- -- the assignment is marked Assignment_OK so that initialization of
- -- limited private records works correctly. This routine may also build
- -- an adjustment call if the component is controlled.
-
procedure Build_Discriminant_Assignments (Statement_List : List_Id);
-- If the record has discriminants, add assignment statements to
-- Statement_List to initialize the discriminant values from the
@@ -2822,127 +2813,6 @@ package body Exp_Ch3 is
-- Determine whether a record initialization procedure needs to be
-- generated for the given record type.
- ----------------------
- -- Build_Assignment --
- ----------------------
-
- function Build_Assignment
- (Id : Entity_Id;
- Default : Node_Id) return List_Id
- is
- Default_Loc : constant Source_Ptr := Sloc (Default);
- Typ : constant Entity_Id := Underlying_Type (Etype (Id));
-
- Exp : Node_Id;
- Exp_Q : Node_Id;
- Lhs : Node_Id;
- Res : List_Id;
-
- begin
- Lhs :=
- Make_Selected_Component (Default_Loc,
- Prefix => Make_Identifier (Loc, Name_uInit),
- Selector_Name => New_Occurrence_Of (Id, Default_Loc));
- Set_Assignment_OK (Lhs);
-
- -- Take copy of Default to ensure that later copies of this component
- -- declaration in derived types see the original tree, not a node
- -- rewritten during expansion of the init_proc. If the copy contains
- -- itypes, the scope of the new itypes is the init_proc being built.
-
- declare
- Map : Elist_Id := No_Elist;
-
- begin
- if Has_Late_Init_Comp then
- -- Map the type to the _Init parameter in order to
- -- handle "current instance" references.
-
- Map := New_Elmt_List
- (Elmt1 => Rec_Type,
- Elmt2 => Defining_Identifier (First
- (Parameter_Specifications
- (Parent (Proc_Id)))));
-
- -- If the type has an incomplete view, a current instance
- -- may have an incomplete type. In that case, it must also be
- -- replaced by the formal of the Init_Proc.
-
- if Present (Incomplete_View (Rec_Type)) then
- Append_Elmt (
- N => Incomplete_View (Rec_Type),
- To => Map);
- Append_Elmt (
- N => Defining_Identifier
- (First
- (Parameter_Specifications
- (Parent (Proc_Id)))),
- To => Map);
- end if;
- end if;
-
- Exp := New_Copy_Tree (Default, New_Scope => Proc_Id, Map => Map);
- end;
-
- Res := New_List (
- Make_Assignment_Statement (Loc,
- Name => Lhs,
- Expression => Exp));
-
- Exp_Q := Unqualify (Exp);
-
- -- Adjust the component if controlled, except if the expression is an
- -- aggregate that will be expanded inline (but note that the case of
- -- container aggregates does require component adjustment), or else
- -- a function call whose result is adjusted in the called function.
- -- Note that, when we don't inhibit component adjustment, the tag
- -- will be automatically inserted by Make_Tag_Ctrl_Assignment in the
- -- tagged case. Otherwise, we have to generate a tag assignment here.
-
- if Needs_Finalization (Typ)
- and then (Nkind (Exp_Q) not in N_Aggregate | N_Extension_Aggregate
- or else Is_Container_Aggregate (Exp_Q))
- and then not Is_Build_In_Place_Function_Call (Exp)
- and then not (Back_End_Return_Slot
- and then Nkind (Exp) = N_Function_Call)
- then
- Set_No_Finalize_Actions (First (Res));
-
- else
- Set_No_Ctrl_Actions (First (Res));
-
- -- Adjust the tag if tagged because of possible view conversions
-
- if Is_Tagged_Type (Typ)
- and then Tagged_Type_Expansion
- and then Nkind (Exp_Q) /= N_Raise_Expression
- then
- declare
- Utyp : Entity_Id := Underlying_Type (Typ);
-
- begin
- -- Get the relevant type for Make_Tag_Assignment_From_Type,
- -- which, for concurrent types is the corresponding record.
-
- if Ekind (Utyp) in E_Protected_Type | E_Task_Type then
- Utyp := Corresponding_Record_Type (Utyp);
- end if;
-
- Append_To (Res,
- Make_Tag_Assignment_From_Type (Default_Loc,
- New_Copy_Tree (Lhs, New_Scope => Proc_Id),
- Utyp));
- end;
- end if;
- end if;
-
- return Res;
-
- exception
- when RE_Not_Available =>
- return Empty_List;
- end Build_Assignment;
-
------------------------------------
-- Build_Discriminant_Assignments --
------------------------------------
@@ -2972,8 +2842,14 @@ package body Exp_Ch3 is
else
D_Loc := Sloc (D);
Append_List_To (Statement_List,
- Build_Assignment (D,
- New_Occurrence_Of (Discriminal (D), D_Loc)));
+ Build_Component_Assignment (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Prefix_Type => Rec_Type,
+ Proc_Id => Proc_Id,
+ Component_Id => D,
+ Default_Expr =>
+ New_Occurrence_Of (Discriminal (D), D_Loc),
+ Is_Incomplete => Has_Late_Init_Comp));
end if;
Next_Discriminant (D);
@@ -4000,7 +3876,14 @@ package body Exp_Ch3 is
Discr_Map => Discr_Map,
Constructor_Ref => Expression (Decl));
else
- Actions := Build_Assignment (Id, Expression (Decl));
+ Actions :=
+ Build_Component_Assignment (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Prefix_Type => Rec_Type,
+ Proc_Id => Proc_Id,
+ Component_Id => Id,
+ Default_Expr => Expression (Decl),
+ Is_Incomplete => Has_Late_Init_Comp);
end if;
-- Expand components with constructors to have the 'Make
@@ -4016,7 +3899,14 @@ package body Exp_Ch3 is
Subtype_Indication
(Component_Definition (Decl))));
Analyze (Expression (Decl));
- Actions := Build_Assignment (Id, Expression (Decl));
+ Actions :=
+ Build_Component_Assignment (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Prefix_Type => Rec_Type,
+ Proc_Id => Proc_Id,
+ Component_Id => Id,
+ Default_Expr => Expression (Decl),
+ Is_Incomplete => Has_Late_Init_Comp);
-- CPU, Dispatching_Domain, Priority, and Secondary_Stack_Size
-- components are filled in with the corresponding rep-item
@@ -4113,7 +4003,14 @@ package body Exp_Ch3 is
Exp := Convert_To (RTE (RE_Size_Type), Exp);
end if;
- Actions := Build_Assignment (Id, Exp);
+ Actions :=
+ Build_Component_Assignment (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Prefix_Type => Rec_Type,
+ Proc_Id => Proc_Id,
+ Component_Id => Id,
+ Default_Expr => Exp,
+ Is_Incomplete => Has_Late_Init_Comp);
-- Nothing needed if no Rep Item
@@ -4194,15 +4091,19 @@ package body Exp_Ch3 is
elsif Component_Needs_Simple_Initialization (Typ) then
Actions :=
- Build_Assignment
- (Id => Id,
- Default =>
- Get_Simple_Init_Val
- (Typ => Typ,
- N => N,
- Size =>
- (if Known_Esize (Id) then Esize (Id)
- else Uint_0)));
+ Build_Component_Assignment (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Prefix_Type => Rec_Type,
+ Proc_Id => Proc_Id,
+ Component_Id => Id,
+ Default_Expr =>
+ Get_Simple_Init_Val
+ (Typ => Typ,
+ N => N,
+ Size =>
+ (if Known_Esize (Id) then Esize (Id)
+ else Uint_0)),
+ Is_Incomplete => Has_Late_Init_Comp);
-- Nothing needed for this case
@@ -4408,7 +4309,13 @@ package body Exp_Ch3 is
then
if Present (Expression (Decl)) then
Append_List_To (Late_Stmts,
- Build_Assignment (Id, Expression (Decl)));
+ Build_Component_Assignment (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Prefix_Type => Rec_Type,
+ Proc_Id => Proc_Id,
+ Component_Id => Id,
+ Default_Expr => Expression (Decl),
+ Is_Incomplete => Has_Late_Init_Comp));
elsif Has_Non_Null_Base_Init_Proc (Typ) then
Append_List_To (Late_Stmts,
@@ -4435,13 +4342,17 @@ package body Exp_Ch3 is
end if;
elsif Component_Needs_Simple_Initialization (Typ) then
Append_List_To (Late_Stmts,
- Build_Assignment
- (Id => Id,
- Default =>
- Get_Simple_Init_Val
- (Typ => Typ,
- N => N,
- Size => Esize (Id))));
+ Build_Component_Assignment (Loc,
+ Prefix => Make_Identifier (Loc, Name_uInit),
+ Prefix_Type => Rec_Type,
+ Proc_Id => Proc_Id,
+ Component_Id => Id,
+ Default_Expr =>
+ Get_Simple_Init_Val
+ (Typ => Typ,
+ N => N,
+ Size => Esize (Id)),
+ Is_Incomplete => Has_Late_Init_Comp));
end if;
end if;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index eb552ea2637..e769d3936f7 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -6500,7 +6500,13 @@ package body Exp_Ch6 is
begin
while Present (Component) loop
- pragma Assert (Ekind (Component) = E_Component);
+
+ -- Skip if not a component, this may happen when initialization
+ -- expressions contain strings.
+
+ if Ekind (Component) /= E_Component then
+ goto Next_Component;
+ end if;
if Chars (Component) = Name_uTag then
null;
@@ -6528,28 +6534,16 @@ package body Exp_Ch6 is
-- specification or as part of the component declaration.
if Present (Maybe_Init_Exp) then
- -- ??? Should reorganize things so that
- -- procedure Build_Assignment in exp_ch3.adb
- -- (which is currently declared inside of
- -- Build_Record_Init_Proc) can be called from here.
- -- That procedure handles some corner cases
- -- that are not properly handled here (e.g.,
- -- mapping current instance references to the
- -- appropriate formal parameter).
-
- if Is_Tagged_Type (Etype (Component)) then
- Append_To (Init_List,
- Make_Tag_Assignment_From_Type (Loc,
- Target => Make_Component_Name,
- Typ => Etype (Component)));
- end if;
-
- Append_To (Init_List,
- Make_Assignment_Statement (Loc,
- Name => Make_Component_Name,
- Expression => New_Copy_Tree
- (Maybe_Init_Exp,
- New_Scope => Body_Id)));
+ Append_List_To (Init_List,
+ Build_Component_Assignment (Loc,
+ Prefix =>
+ New_Occurrence_Of (First_Formal (Spec_Id), Loc),
+ Prefix_Type => First_Param_Type,
+ Proc_Id => Body_Id,
+ Component_Id => Component,
+ Default_Expr => New_Copy_Tree
+ (Maybe_Init_Exp,
+ New_Scope => Body_Id)));
-- Handle case where component's type has an init proc
elsif Has_Non_Null_Base_Init_Proc (Etype (Component)) then
@@ -6563,6 +6557,7 @@ package body Exp_Ch6 is
end;
end if;
+ <<Next_Component>>
Next_Entity (Component);
end loop;
diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb
index c2346844d0b..7605ff9e576 100644
--- a/gcc/ada/exp_util.adb
+++ b/gcc/ada/exp_util.adb
@@ -1800,6 +1800,133 @@ package body Exp_Util is
Replace_Condition_Entities (Pragma_Or_Expr);
end Build_Class_Wide_Expression;
+ --------------------------------
+ -- Build_Component_Assignment --
+ --------------------------------
+
+ function Build_Component_Assignment
+ (Loc : Source_Ptr;
+ Prefix : Node_Id;
+ Prefix_Type : Entity_Id;
+ Proc_Id : Entity_Id;
+ Component_Id : Entity_Id;
+ Default_Expr : Node_Id;
+ Is_Incomplete : Boolean := False) return List_Id
+ is
+ Default_Loc : constant Source_Ptr := Sloc (Default_Expr);
+ Typ : constant Entity_Id :=
+ Underlying_Type (Etype (Component_Id));
+
+ Exp : Node_Id;
+ Exp_Q : Node_Id;
+ Lhs : Node_Id;
+ Res : List_Id;
+
+ begin
+ Lhs :=
+ Make_Selected_Component (Default_Loc,
+ Prefix => Prefix,
+ Selector_Name => New_Occurrence_Of (Component_Id, Default_Loc));
+ Set_Assignment_OK (Lhs);
+
+ -- Take copy of Default to ensure that later copies of this component
+ -- declaration in derived types see the original tree, not a node
+ -- rewritten during expansion. If the copy contains itypes, the scope of
+ -- the new itypes is the type being built.
+
+ declare
+ Map : Elist_Id := No_Elist;
+
+ begin
+ if Is_Incomplete then
+ -- Map the type to the first formal in order to handle "current
+ -- instance" references.
+
+ Map := New_Elmt_List
+ (Elmt1 => Prefix_Type,
+ Elmt2 => Defining_Identifier (First
+ (Parameter_Specifications
+ (Parent (Proc_Id)))));
+
+ -- If the type has an incomplete view, a current instance may have
+ -- an incomplete type. In that case, it must also be replaced by
+ -- the formal of the current procedure.
+
+ if Present (Incomplete_View (Prefix_Type)) then
+ Append_Elmt (
+ N => Incomplete_View (Prefix_Type),
+ To => Map);
+ Append_Elmt (
+ N => Defining_Identifier
+ (First
+ (Parameter_Specifications
+ (Parent (Proc_Id)))),
+ To => Map);
+ end if;
+ end if;
+
+ Exp := New_Copy_Tree (Default_Expr, New_Scope => Proc_Id, Map => Map);
+ end;
+
+ Res := New_List (
+ Make_Assignment_Statement (Loc,
+ Name => Lhs,
+ Expression => Exp));
+
+ Exp_Q := Unqualify (Exp);
+
+ -- Adjust the component if controlled, except if the expression is an
+ -- aggregate that will be expanded inline (but note that the case of
+ -- container aggregates does require component adjustment), or else a
+ -- function call whose result is adjusted in the called function.
+ -- Note that, when we don't inhibit component adjustment, the tag will
+ -- be automatically inserted by Make_Tag_Ctrl_Assignment in the tagged
+ -- case. Otherwise, we have to generate a tag assignment here.
+
+ if Needs_Finalization (Typ)
+ and then (Nkind (Exp_Q) not in N_Aggregate | N_Extension_Aggregate
+ or else Is_Container_Aggregate (Exp_Q))
+ and then not Is_Build_In_Place_Function_Call (Exp)
+ and then not (Back_End_Return_Slot
+ and then Nkind (Exp) = N_Function_Call)
+ then
+ Set_No_Finalize_Actions (First (Res));
+
+ else
+ Set_No_Ctrl_Actions (First (Res));
+
+ -- Adjust the tag if tagged because of possible view conversions
+
+ if Is_Tagged_Type (Typ)
+ and then Tagged_Type_Expansion
+ and then Nkind (Exp_Q) /= N_Raise_Expression
+ then
+ declare
+ Utyp : Entity_Id := Underlying_Type (Typ);
+
+ begin
+ -- Get the relevant type for Make_Tag_Assignment_From_Type,
+ -- which, for concurrent types is the corresponding record.
+
+ if Ekind (Utyp) in E_Protected_Type | E_Task_Type then
+ Utyp := Corresponding_Record_Type (Utyp);
+ end if;
+
+ Append_To (Res,
+ Make_Tag_Assignment_From_Type (Default_Loc,
+ New_Copy_Tree (Lhs, New_Scope => Proc_Id),
+ Utyp));
+ end;
+ end if;
+ end if;
+
+ return Res;
+
+ exception
+ when RE_Not_Available =>
+ return Empty_List;
+ end Build_Component_Assignment;
+
--------------------
-- Build_DIC_Call --
--------------------
diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads
index 6ebda7f4499..c12d68b27b2 100644
--- a/gcc/ada/exp_util.ads
+++ b/gcc/ada/exp_util.ads
@@ -328,6 +328,27 @@ package Exp_Util is
-- operation that has the condition. Adjust_Sloc is True when the sloc of
-- nodes traversed should be adjusted for the inherited pragma.
+ function Build_Component_Assignment
+ (Loc : Source_Ptr;
+ Prefix : Entity_Id;
+ Prefix_Type : Entity_Id;
+ Proc_Id : Entity_Id;
+ Component_Id : Entity_Id;
+ Default_Expr : Node_Id;
+ Is_Incomplete : Boolean := False) return List_Id;
+ -- This helper function is used to build component assignment in
+ -- initialization procedures or constructor prologues. It builds an
+ -- assignment statement that assigns the default expression to its
+ -- corresponding record component, selected with the first formal for
+ -- visibility. The right-hand side of the assignment, cf. the default
+ -- expression, is scoped in the given procedure, the left-hand side is
+ -- marked Assignment_OK so that initialization of limited private records
+ -- works correctly. This routine may also build an adjustment call if the
+ -- component is controlled.
+ -- If Is_Incomplete is true, the entities in the default expression will
+ -- be mapped to the type of the first formal in order to handle "current
+ -- instance" references.
+
function Build_DIC_Call
(Loc : Source_Ptr;
Obj_Name : Node_Id;
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 30cdaeb4a7e..dc7bc74a5a9 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -674,13 +674,13 @@ package body Sem_Ch5 is
-- Error of assigning to limited type. We do however allow this in
-- certain cases where the front end generates the assignments.
-- Comes_From_Source test is needed to allow compiler-generated
- -- constructor calls or streaming/put_image subprograms, which may
- -- ignore privacy.
+ -- streaming/put_image subprograms, which may ignore privacy.
elsif Is_Limited_Type (T1)
and then not Assignment_OK (Lhs)
and then not Assignment_OK (Original_Node (Lhs))
- and then Comes_From_Source (N)
+ and then (Comes_From_Source (N)
+ or else Is_Immutably_Limited_Type (T1))
then
-- CPP constructors can only be called in declarations
--
2.53.0
