https://gcc.gnu.org/g:811c4fd05109827f4e9ef8c22c22b8340b6b4a7d
commit r17-718-g811c4fd05109827f4e9ef8c22c22b8340b6b4a7d Author: Denis Mazzucato <[email protected]> Date: Tue Dec 16 11:16:32 2025 +0100 ada: Refactor assignments in constructor prologue 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. Diff: --- 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 db0a32e46812..13cf7bad88c4 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 eb552ea26376..e769d3936f70 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 c2346844d0be..7605ff9e576c 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 6ebda7f44993..c12d68b27b2c 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 30cdaeb4a7e0..dc7bc74a5a90 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
