https://gcc.gnu.org/g:190643888694dae2ed35bf2b24d8f4646f1ec228
commit r17-737-g190643888694dae2ed35bf2b24d8f4646f1ec228 Author: Denis Mazzucato <[email protected]> Date: Fri Jan 9 16:04:57 2026 +0100 ada: Fix Initialize aspect for constructors This patch improve the analysis for the Initialize aspect in constructor bodies. Specifically: - Assignments based on the Initialize aspect are always placed at the end of the constructor prologue, otherwise they could be overwritten depending on the original order of components. - Introduce the "others" default choice for the Initialize aggregate. - Improve diagnostics when the Initialize aspect is clearly misspelled. - Flag components that are required to be initialized but are missing from the Initialize aspect. - Check whether aggregate choices refer to ancestors, which is not allowed. gcc/ada/ChangeLog: * exp_ch3.adb (Build_Implicit_Parameterless_Constructor): Add Initialize aspect with default others to trigger Initialize aspect analysis. * exp_ch6.adb (Prepend_Constructor_Procedure_Prologue): Fix initialization order. (Init_From_Initialize_Expression): Retrieve initialization expression or the default one base on the Initialize aspect. (Init_From_Default_Or_Constructor):. Retrieve initialization expression based on the default one in the record initialization list or the init procedure. * sem_ch13.adb (Analyze_Aspect_Specifications): Add check for missing components that require initialization, and add an expression_with_action node to place ABE during resolution of aggregates with function calls. (Check_Constructor_Choices): Helper to check that the aggregate choices do not refer to ancestors. (Diagnose_Misplaced_Aspects): Improve diagnostics when it is a clear misspelling of Initialize aspect. * sem_ch6.adb (Analyze_Direct_Attribute_Definition): If missing, add a compiler generated Initialize aspect with default others to trigger Initialize analysis. Diff: --- gcc/ada/exp_ch3.adb | 15 ++++- gcc/ada/exp_ch6.adb | 144 ++++++++++++++++++++++++++++++-------------- gcc/ada/sem_ch13.adb | 166 ++++++++++++++++++++++++++++++++++++++++++++++----- gcc/ada/sem_ch6.adb | 40 ++++++++++++- 4 files changed, 302 insertions(+), 63 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index b934c9061e3e..1b7b4aae653c 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -2040,13 +2040,24 @@ package body Exp_Ch3 is Freeze_Extra_Formals (Constructor_Id); declare - Ignore : Node_Id; + Ignore : Node_Id; + Default_Initialize : constant Node_Id := + Make_Aspect_Specification (Loc, + Identifier => Make_Identifier (Loc, Name_Initialize), + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List (Make_Others_Choice (Loc)), + Box_Present => True)), + Is_Parenthesis_Aggregate => True)); begin Ignore := Make_Subprogram_Body (Loc, Specification => Spec_Node, Handled_Statement_Sequence => - Make_Handled_Sequence_Of_Statements (Loc)); + Make_Handled_Sequence_Of_Statements (Loc), + Aspect_Specifications => New_List (Default_Initialize)); end; Set_Is_Public (Constructor_Id, Is_Public (Typ)); diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 50fffdffd8e2..9a16229e3354 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6366,16 +6366,28 @@ package body Exp_Ch6 is else Empty); Component : Entity_Id := First_Entity (First_Param_Type); - Init_List : constant List_Id := New_List; - - function Init_Expression_If_Any (Component : Entity_Id) - return Node_Id; - -- If the given component is mentioned in the Initialize - -- aspect for the constructor procedure, then return the - -- initial value expression specified there. - -- Otherwise, if the component declaration includes an - -- initial value expression, then return that expression. - -- Otherwise, return Empty. + Comp_List, Initialize_List, Tag_List, Parent_List : + constant List_Id := New_List; + -- Comp_List contains the list of default initializations, init + -- procedure calls, or constructor calls for components; + -- Initialize_List contains the list of component initializations + -- coming from the Initialize aspect; + -- Tag_List contains the initialization for the tag; + -- Parent_List contains the parent constructor call. + + function Init_From_Initialize_Expression + (Component : Entity_Id) return Node_Id; + -- If the Initialize aspect for the constructor procedure contains + -- the given component or the default others, then return the + -- initial value expression specified there. Otherwise, return + -- Empty. + + function Init_From_Default_Or_Constructor + (Component : Entity_Id) return Node_Id; + -- If the component declaration includes a default initial value + -- expression or its type has a parameterless constructor + -- available, then return that expression (or a corresponding Make + -- call in the constructor case). Otherwise, return Empty. function Make_Init_Proc_Call (Component : Entity_Id; Component_Name : Node_Id) @@ -6391,39 +6403,55 @@ package body Exp_Ch6 is -- This function is called only in the case of a -- Constructor procedure for a type extension. - ---------------------------- - -- Init_Expression_If_Any -- - ---------------------------- + -------------------------------- + -- From_Initialize_Expression -- + -------------------------------- - function Init_Expression_If_Any (Component : Entity_Id) + function Init_From_Initialize_Expression (Component : Entity_Id) return Node_Id is - Initialize_Comp_Assoc : Node_Id := First_Initialize_Comp_Assoc; - Choice : Node_Id; + Component_Cursor : Node_Id := First_Initialize_Comp_Assoc; + Choice : Node_Id; + Others_Expression : Node_Id := Empty; -- ??? Technically, this is quadratic (linear search called -- a linear number of times). When/if we see performance -- problems with hundreds of components mentioned in one -- Initialize aspect specification, we can revisit this. begin - while Present (Initialize_Comp_Assoc) loop - Choice := First (Choices (Initialize_Comp_Assoc)); + while Present (Component_Cursor) loop + Choice := First (Choices (Component_Cursor)); while Present (Choice) loop - if Nkind (Choice) = N_Identifier + -- The others expression is used in case there is no + -- explicit component association for the given one. + + if Nkind (Choice) = N_Others_Choice + and then Comes_From_Source (Choice) + then + Others_Expression := Expression (Component_Cursor); + + elsif Nkind (Choice) = N_Identifier and then Chars (Choice) = Chars (Component) then - return Expression (Initialize_Comp_Assoc); + return Expression (Component_Cursor); end if; Next (Choice); end loop; - Next (Initialize_Comp_Assoc); + Next (Component_Cursor); end loop; - -- If a default expression is present in the record - -- declaration, then use it. + return Others_Expression; + end Init_From_Initialize_Expression; + -------------------------------------- + -- Init_From_Default_Or_Constructor -- + -------------------------------------- + + function Init_From_Default_Or_Constructor (Component : Entity_Id) + return Node_Id is + begin if Present (Expression (Parent (Component))) then return Expression (Parent (Component)); end if; @@ -6442,7 +6470,7 @@ package body Exp_Ch6 is end if; return Empty; - end Init_Expression_If_Any; + end Init_From_Default_Or_Constructor; ------------------------- -- Make_Init_Proc_Call -- @@ -6544,7 +6572,7 @@ package body Exp_Ch6 is end if; if Chars (Component) = Name_uTag then - Append_To (Init_List, + Append_To (Tag_List, Make_Tag_Assignment_From_Type (Loc, Target => New_Occurrence_Of (First_Formal (Spec_Id), Loc), @@ -6553,13 +6581,16 @@ package body Exp_Ch6 is elsif Chars (Component) = Name_uParent and then Needs_Construction (Etype (Component)) then - Append_To (Init_List, Make_Parent_Constructor_Call - (Parent_Type => Etype (Component))); + Append_To (Parent_List, + Make_Parent_Constructor_Call + (Parent_Type => Etype (Component))); else declare - Maybe_Init_Exp : constant Node_Id := - Init_Expression_If_Any (Component); + Maybe_Initialize : constant Node_Id := + Init_From_Initialize_Expression (Component); + Maybe_Default_Or_Constructor : constant Node_Id := + Init_From_Default_Or_Constructor (Component); function Make_Component_Name return Node_Id is (Make_Selected_Component (Loc, @@ -6568,25 +6599,39 @@ package body Exp_Ch6 is Selector_Name => Make_Identifier (Loc, Chars (Component)))); begin - -- Handle case where initial value for this component - -- is specified either in an Initialize aspect - -- specification or as part of the component declaration. - - if Present (Maybe_Init_Exp) then - 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 initial value for this component is + -- specified either in an Initialize aspect specification + -- or as part of the component declaration. + + if Present (Maybe_Initialize) + or else Present (Maybe_Default_Or_Constructor) + then + declare + Init : Node_Id; + List : List_Id; + begin + if Present (Maybe_Initialize) then + Init := Maybe_Initialize; + List := Initialize_List; + else + Init := Maybe_Default_Or_Constructor; + List := Comp_List; + end if; + Append_List_To (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 (Init, New_Scope => Body_Id))); + end; -- Handle case where component's type has an init proc elsif Has_Non_Null_Base_Init_Proc (Etype (Component)) then - Append_To (Init_List, + Append_To (Comp_List, Make_Init_Proc_Call ( Component => Component, Component_Name => Make_Component_Name)); @@ -6600,7 +6645,14 @@ package body Exp_Ch6 is Next_Entity (Component); end loop; - Insert_List_Before_And_Analyze (First (L), Init_List); + -- First, use default value initializations and init procedures, + -- then call the parent constructor (if any), then initialize all + -- other components through the Initialize aspect, last the tag. + + Append_List (Tag_List, Initialize_List); + Append_List (Initialize_List, Parent_List); + Append_List (Parent_List, Comp_List); + Insert_List_Before_And_Analyze (First (L), Comp_List); end; Pop_Scope; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index c72fd6bd8b5b..7c13299f85f1 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2134,8 +2134,14 @@ package body Sem_Ch13 is procedure Analyze_Aspect_Static; -- Ada 2022 (AI12-0075): Perform analysis of aspect Static + procedure Check_Constructor_Choices (Choice_List : List_Id); + -- Check that each choice occurring in the aggregate of a + -- contructor Initialize aspect specification represents a + -- component that belongs to the current type, otherwise flag an + -- error as initialization of parent components is not permitted. + procedure Check_Constructor_Initialization_Expression - (Expr : Node_Id; Aspect_Name : String); + (Expr : Node_Id; Aspect : Name_Id); -- Check legality rules for an expression occurring as -- an expression of a Super or Initialize aspect specification. -- These expressions are evaluated before the constructed @@ -3296,12 +3302,49 @@ package body Sem_Ch13 is end if; end Analyze_Aspect_Yield; + ------------------------------- + -- Check_Constructor_Choices -- + ------------------------------- + + procedure Check_Constructor_Choices (Choice_List : List_Id) is + Choice_Cursor : Node_Id := First (Choice_List); + Component_Cursor : Node_Id; + begin + while Present (Choice_Cursor) loop + if Nkind (Choice_Cursor) = N_Others_Choice then + goto Next_Choice; + end if; + + Component_Cursor := First_Entity (Etype (First_Entity (E))); + while Present (Component_Cursor) loop + if Ekind (Component_Cursor) = E_Component + and then Chars (Component_Cursor) + = Chars (Choice_Cursor) + then + if Original_Record_Component (Component_Cursor) + /= Component_Cursor + then + Error_Msg_N + ("cannot initialize parent component&", + Choice_Cursor); + end if; + exit; + end if; + + Next_Entity (Component_Cursor); + end loop; + + <<Next_Choice>> + Next (Choice_Cursor); + end loop; + end Check_Constructor_Choices; + ------------------------------------------------- -- Check_Constructor_Initialization_Expression -- ------------------------------------------------- procedure Check_Constructor_Initialization_Expression - (Expr : Node_Id; Aspect_Name : String) + (Expr : Node_Id; Aspect : Name_Id) is First_Parameter : Entity_Id; @@ -3319,9 +3362,10 @@ package body Sem_Ch13 is if Nkind (N) = N_Identifier and then Entity (N) = First_Parameter then + Error_Msg_Name_1 := Aspect; Error_Msg_N - ("constructed object referenced in " & - Aspect_Name & " aspect_specification", N); + ("constructed object referenced in% " & + "aspect_specification", N); end if; return OK; @@ -3330,6 +3374,8 @@ package body Sem_Ch13 is procedure Check_Tree_For_Bad_Reference is new Traverse_Proc (Check_Node_For_Bad_Reference); begin + pragma Assert (Aspect in Name_Super | Name_Initialize); + -- If coming from an implicit constructor, the Self parameter -- is retrieved via the specification's defining unit name. @@ -4497,8 +4543,10 @@ package body Sem_Ch13 is when Aspect_Initialize => Initialize : declare Aspect_Comp : Node_Id; Type_Comp : Node_Id; - Typ : Entity_Id; - Dummy_Aggr : Node_Id; + Typ : Entity_Id; + Dummy : Node_Id; + + Has_User_Defined_Default : Boolean := False; begin -- Error checking @@ -4508,8 +4556,13 @@ package body Sem_Ch13 is goto Continue; end if; - if Ekind (E) /= E_Subprogram_Body - or else Nkind (Parent (E)) /= N_Procedure_Specification + -- Initialize aspect can only apply to a constructor body or + -- to the implicit constructors, which are represented by + -- procedure specs. + + if (Ekind (E) /= E_Subprogram_Body + or else Nkind (Parent (E)) /= N_Procedure_Specification) + and then not Acts_As_Spec (N) then Error_Msg_N ("Initialize must apply to a constructor body", N); @@ -4519,6 +4572,14 @@ package body Sem_Ch13 is Error_Msg_N ("only component associations allowed", N); end if; + -- Errors may suggest missing self parameters or wrong + -- constructor profile, the analysis would crash if we + -- continue. + + if Error_Posted (N) then + goto Continue; + end if; + -- Install the others for the aggregate if necessary Typ := Etype (First_Entity (E)); @@ -4529,6 +4590,13 @@ package body Sem_Ch13 is & " whose type has one or more components", N); end if; + -- Here it follows three loops: the first is linear over the + -- components, the second is quadratic over the components + -- and then aggregate choices, the last is quadratic over + -- the aggregate choices and then components (hidden by the + -- Check_Constructor_Choices). If this becomes a performance + -- issue we can merge all loops together ??? + Aspect_Comp := First (Component_Associations (Expression (Aspect))); Type_Comp := First_Entity (Typ); @@ -4544,6 +4612,7 @@ package body Sem_Ch13 is elsif Nkind (First (Choices (Aspect_Comp))) = N_Others_Choice then + Has_User_Defined_Default := Comes_From_Source (Aspect); exit; end if; @@ -4551,7 +4620,60 @@ package body Sem_Ch13 is Next_Entity (Type_Comp); end loop; - -- Analyze the components + -- Flag components that are missing a required explicit + -- initialization, that is the case for by-constructor types + -- without the parameterless constructor that have no + -- default expression and are not choiced in the Initialize + -- aggregate. + + if not Has_User_Defined_Default then + Type_Comp := First_Entity (Typ); + while Present (Type_Comp) loop + if Ekind (Type_Comp) /= E_Component + or else Chars (Type_Comp) in Name_uTag | Name_uParent + then + goto Next_Component; + end if; + + -- Check if the component needs to be initialized by + -- the Initialize aspect specification. + + if Needs_Construction (Etype (Type_Comp)) + and then No (Expression (Parent (Type_Comp))) + then + Aspect_Comp := First ( + Component_Associations (Expression (Aspect))); + while Present (Aspect_Comp) loop + declare + Cursor_Choice : Node_Id := + First (Choices (Aspect_Comp)); + begin + while Present (Cursor_Choice) loop + if Nkind (Cursor_Choice) /= N_Others_Choice + and then Chars (Type_Comp) + = Chars (Cursor_Choice) + then + goto Next_Component; + end if; + + Next (Cursor_Choice); + end loop; + end; + + Next (Aspect_Comp); + end loop; + + Error_Msg_NE ("explicit initialization required " & + "for component&", + Aspect, Type_Comp); + end if; + + <<Next_Component>> + Next_Entity (Type_Comp); + end loop; + end if; + + -- Analyze the components, both expressions and choices Aspect_Comp := First (Component_Associations (Expression (Aspect))); @@ -4562,18 +4684,24 @@ package body Sem_Ch13 is if Present (Expr) then Analyze (Expr); Check_Constructor_Initialization_Expression - (Expr, Aspect_Name => "Initialize"); + (Expr, Aspect => Name_Initialize); end if; end; + Check_Constructor_Choices (Choices (Aspect_Comp)); Next (Aspect_Comp); end loop; - -- Do a psuedo pass over the aggregate to ensure it is valid + -- Do a psuedo pass over the aggregate to ensure its + -- validity. The expression with actions is required to + -- have a valid node where to place the ABE check during + -- resolution. Expander_Active := False; - Dummy_Aggr := New_Copy_Tree (Expression (Aspect)); - Resolve_Aggregate (Dummy_Aggr, Typ); + Dummy := Make_Expression_With_Actions (Loc, + Actions => Empty_List, + Expression => New_Copy_Tree (Expression (Aspect))); + Resolve_Aggregate (Expression (Dummy), Typ); Expander_Active := True; end Initialize; @@ -5330,7 +5458,7 @@ package body Sem_Ch13 is -- To reverse this decision, set this flag to False. procedure Check_Super_Arg - (Expr : Node_Id; Aspect_Name : String := "Super") + (Expr : Node_Id; Aspect : Name_Id := Name_Super) renames Check_Constructor_Initialization_Expression; begin @@ -6054,6 +6182,16 @@ package body Sem_Ch13 is Error_Msg_N ("aspect specification must appear on initial declaration", Asp); + + -- Improve the error message for likely misspelling since the + -- Initialize aspect (singular) can be used in stubs but the + -- Initializes aspect (plural) cannot and would raise a + -- misleading error here. + + if Asp_Nam = Name_Initializes then + Error_Msg_Name_1 := Name_Initialize; + Error_Msg_N ("\possible misspelling of%", Asp); + end if; end if; Next (Asp); diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 0886f650152c..666627bee8e7 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5274,10 +5274,42 @@ package body Sem_Ch6 is ----------------------------------------- procedure Analyze_Direct_Attribute_Definition (Designator : Entity_Id) is + procedure Add_Default_Initialize_Aspect; + -- Adds a default Initialize aspect specification to the body stub of + -- the Designator. + function Can_Be_Destructor_Of (E : Entity_Id; T : Entity_Id) return Boolean; -- Returns whether E can be declared the destructor of T + ----------------------------------- + -- Add_Default_Initialize_Aspect -- + ----------------------------------- + + procedure Add_Default_Initialize_Aspect is + Body_N : constant Node_Id := Unit_Declaration_Node (Designator); + Loc : constant Source_Ptr := Sloc (Body_N); + + Default_Initialize : constant Node_Id := + Make_Aspect_Specification (Loc, + Identifier => Make_Identifier (Loc, Name_Initialize), + Expression => + Make_Aggregate (Loc, + Component_Associations => New_List ( + Make_Component_Association (Loc, + Choices => New_List (Make_Others_Choice (Loc)), + Box_Present => True)), + Is_Parenthesis_Aggregate => True)); + begin + if No (Aspect_Specifications (Body_N)) then + Set_Aspect_Specifications + (Body_N, + New_List (Default_Initialize)); + else + Append_To (Aspect_Specifications (Body_N), Default_Initialize); + end if; + end Add_Default_Initialize_Aspect; + -------------------------- -- Can_Be_Destructor_Of -- -------------------------- @@ -5320,9 +5352,15 @@ package body Sem_Ch6 is when Name_Constructor => Error_Msg_Name_1 := Att_Name; - -- No further action required in a subprogram body + -- If missing, add a default initialization aspect for this + -- constructor's body stub: Initialize => (others => <>). if Parent_Kind (N) not in N_Subprogram_Declaration then + if not Has_Aspect (Designator, Aspect_Initialize) then + Add_Default_Initialize_Aspect; + end if; + + -- No further action required in a subprogram body return; elsif No (Prefix_E) or else not Is_Type (Prefix_E) then
