https://gcc.gnu.org/g:37ebb43231ca61e65364128baafcc0dec89ac08f
commit r17-1968-g37ebb43231ca61e65364128baafcc0dec89ac08f Author: Javier Miranda <[email protected]> Date: Mon Jun 15 11:05:45 2026 +0000 ada: Fix support for initialization of components in constructors Enforce the following rule: If the component of a record type is of a type that doesn't have a parameterless constructor, it has to be initialized by one of these two mechanism: 1) through the default value provided at component declaration, or 2) through an Initialize aspect that can rely on constructor parameters. Enforce the following rule: a constructor for a derived type whose parent type needs construction and has no default parameterless constructor must call the parent constructor through a Super aspect to initialize its parent components. Fix order of initialization of derived record type components. gcc/ada/ChangeLog: * sem_ch6.adb (Constructor_Components_OK): New local subprogram of Analyze_Direct_Attribute_Definition. Checks performed when processing the body of a constructor. (Analyze_Direct_Attribute_Definition) <Name_Constructor>: Report an error on the body of a constructor for a derived type whose parent type needs construction and has no default parameterless constructor and has no Super aspect to initialize its parent components. * sem_ch7.adb (Inspect_Components_Needing_Construction): New local subprogram of Analyze_Package_Specification. (Inspect_Abstract_Constructors_Completion): Rename formal parameter. * exp_ch6.adb (Prepend_Constructor_Procedure_Prologue): Fix the order of initialization of record type components: parent components must be initialized first, then the own components following their declaration order. * sem_util.ads (First_Component_Declaration): New subprogram. * sem_util.adb (First_Component_Declaration): New utility subprogram that returns the first non-pragma non-inherited component declaration of a record type. Diff: --- gcc/ada/exp_ch6.adb | 54 ++++++++++++++++++----------- gcc/ada/sem_ch6.adb | 97 +++++++++++++++++++++++++++++++++++++++++++++------- gcc/ada/sem_ch7.adb | 62 ++++++++++++++++++++++++++++++--- gcc/ada/sem_util.adb | 36 +++++++++++++++++++ gcc/ada/sem_util.ads | 10 ++++++ 5 files changed, 223 insertions(+), 36 deletions(-) diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 21275bbfe187..d9ab5ee108cb 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6145,13 +6145,14 @@ package body Exp_Ch6 is Component : Entity_Id; Comp_List : constant List_Id := New_List; - Initialize_List : constant List_Id := New_List; Tag_List : constant List_Id := New_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; + -- Comp_List contains component initializations (from the Initialize + -- aspect or component default expressions), in record declaration + -- order; when a component is named in the Initialize aspect, that + -- expression takes priority over the component's default expression, + -- which is used only when the component is not mentioned in the + -- Initialize aspect; -- Tag_List contains the initialization for the tag; -- Parent_List contains the parent constructor call. @@ -6200,10 +6201,13 @@ package body Exp_Ch6 is end if; if Chars (Component) = Name_uTag then - Append_To (Tag_List, - Make_Tag_Assignment_From_Type (Loc, - Target => New_Occurrence_Of (First_Formal (Spec_Id), Loc), - Typ => First_Param_Type)); + if Tagged_Type_Expansion then + Append_To (Tag_List, + Make_Tag_Assignment_From_Type (Loc, + Target => + New_Occurrence_Of (First_Formal (Spec_Id), Loc), + Typ => First_Param_Type)); + end if; elsif Chars (Component) = Name_uParent and then Needs_Construction (Etype (Component)) @@ -6215,6 +6219,21 @@ package body Exp_Ch6 is Make_Parent_Constructor_Call (Parent_Type => Etype (Component))); + -- Inherited components are handled by the parent constructor + + elsif Original_Record_Component (Component) /= Component then + null; + + -- A derived type with a parent that needs construction has a + -- Super aspect that initializes its parent components; otherwise + -- it had been rejected during semantic analysis (see subprogram + -- Sem_Ch6.Analyze_Direct_Attribute_Definition). + + elsif Chars (Component) = Name_uParent + and then Needs_Construction (Etype (Component)) + then + null; + else declare Maybe_Initialize : constant Node_Id := @@ -6238,18 +6257,15 @@ package body Exp_Ch6 is 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, + Append_List_To (Comp_List, Build_Component_Assignment (Loc, Prefix => New_Occurrence_Of (First_Formal (Spec_Id), Loc), @@ -6289,14 +6305,12 @@ package body Exp_Ch6 is Next_Entity (Component); end loop; - -- 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. + -- First call the parent constructor (if any), then initialize all + -- components in record declaration order, then set 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); + Append_List (Comp_List, Parent_List); + Append_List (Tag_List, Parent_List); + Insert_List_Before_And_Analyze (First (L), Parent_List); End_Scope; end Prepend_Constructor_Procedure_Prologue; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index 0f886a5db564..a2028768c403 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5244,6 +5244,15 @@ package body Sem_Ch6 is -- already explicitly specifies the aspect or inherits the aspect -- from a type that explicitly specifies it. + function Constructor_Components_OK + (Typ : Entity_Id; Subp : Node_Id) return Boolean; + -- Called when processing the body of a constructor for record type + -- Typ. Checks non-inherited components of Typ and reports an error + -- on each component whose type is a record type with no default + -- parameterless constructor, no default initialization, and no + -- explicit default expression. Returns True if no such component + -- is found, and False if at least one error was emitted. + ----------------------------------- -- Add_Default_Initialize_Aspect -- ----------------------------------- @@ -5362,12 +5371,50 @@ package body Sem_Ch6 is end if; end Create_And_Append_Aspect; + ------------------------------- + -- Constructor_Components_OK -- + ------------------------------- + + function Constructor_Components_OK + (Typ : Entity_Id; Subp : Node_Id) return Boolean + is + Comp_Decl : Node_Id; + Comp_Id : Entity_Id; + Comp_Typ : Entity_Id; + OK : Boolean := True; + + begin + Comp_Decl := First_Component_Declaration (Typ); + while Present (Comp_Decl) loop + if Nkind (Comp_Decl) = N_Component_Declaration then + Comp_Id := Defining_Identifier (Comp_Decl); + Comp_Typ := Etype (Comp_Id); + + if Chars (Comp_Id) /= Name_uParent + and then Is_Record_Type (Comp_Typ) + and then not Has_Parameterless_Constructor (Comp_Typ) + and then not Is_Fully_Initialized_Type (Comp_Typ) + and then No (Expression (Comp_Decl)) + then + Error_Msg_NE + ("explicit initialization required for component &", + Subp, Comp_Id); + OK := False; + end if; + end if; + + Next_Non_Pragma (Comp_Decl); + end loop; + + return OK; + end Constructor_Components_OK; + -- Local variables - Att_N : constant Node_Id := Original_Node (N); - Att_Prefix : constant Node_Id := Prefix (Defining_Unit_Name (Att_N)); - Att_Name : constant Name_Id := - Attribute_Name (Defining_Unit_Name (Att_N)); + Att_N : constant Node_Id := Original_Node (N); + Def_Name : constant Entity_Id := Defining_Unit_Name (Att_N); + Att_Name : constant Name_Id := Attribute_Name (Def_Name); + Att_Prefix : constant Node_Id := Prefix (Def_Name); Is_Class_Wide_Attr : constant Boolean := Nkind (Att_Prefix) = N_Attribute_Reference @@ -5384,6 +5431,9 @@ package body Sem_Ch6 is -- Start of processing for Analyze_Direct_Attribute_Definition begin + -- This node has been rewritten by the parser subprogram + -- Rewrite_Entity_If_Direct_Attribute_Def (par-ch6.adb) + pragma Assert (N /= Att_N); Error_Msg_Name_1 := Att_Name; @@ -5437,13 +5487,36 @@ package body Sem_Ch6 is case Att_Name is when Name_Constructor => - -- If missing, add a default initialization aspect for this - -- constructor's body stub: Initialize => (others => <>). - if Parent_Kind (N) not in N_Subprogram_Declaration - | N_Abstract_Subprogram_Declaration - then - if not Has_Aspect (Designator, Aspect_Initialize) then + if Parent_Kind (N) = N_Subprogram_Body then + + -- A constructor body for a derived type whose parent type + -- needs construction and has no parameterless constructor + -- must call its parent constructor through a Super aspect + -- to initialize its parent components. + + if Present (Prefix_E) + and then Is_Tagged_Type (Prefix_E) + and then Is_Derived_Type (Prefix_E) + and then Needs_Construction (Etype (Prefix_E)) + and then + not Has_Parameterless_Constructor (Etype (Prefix_E)) + and then No (Find_Aspect (Designator, Aspect_Super)) + then + Error_Msg_Name_1 := Name_Super; + Error_Msg_NE + ("missing % aspect to initialize components of parent" + & " type &", Designator, Etype (Prefix_E)); + end if; + + -- If missing, add a default initialization aspect for this + -- constructor's body: Initialize => (others => <>). + + if not Has_Aspect (Designator, Aspect_Initialize) + and then Present (Prefix_E) + and then Ekind (Prefix_E) = E_Record_Type + and then Constructor_Components_OK (Prefix_E, Designator) + then Add_Default_Initialize_Aspect; end if; @@ -5453,7 +5526,7 @@ package body Sem_Ch6 is elsif No (Prefix_E) or else not Is_Type (Prefix_E) then Error_Msg_N ("prefix& of attribute% must be a type", - Prefix (Defining_Unit_Name (Att_N))); + Prefix (Def_Name)); elsif Ekind (Designator) /= E_Procedure then Error_Msg_N @@ -5470,7 +5543,7 @@ package body Sem_Ch6 is then Sloc (N) else Sloc (First_Formal (Designator))); begin - Error_Msg_Node_1 := Defining_Unit_Name (Att_N); + Error_Msg_Node_1 := Def_Name; Error_Msg_Node_2 := Prefix_E; Error_Msg ("& must have a first IN OUT formal of type&", Problem); diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 2709f0eb66a2..22317dd9a931 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1337,11 +1337,18 @@ package body Sem_Ch7 is -- primitive equality operator and, if so, make it so that it will be -- used as the predefined operator of the private view of the record. - procedure Inspect_Abstract_Constructors_Completion (Id : Entity_Id); + procedure Inspect_Abstract_Constructors_Completion (Pkg_Id : Entity_Id); -- For each abstract constructor in the visible part of package Id, -- verify that a non-abstract counterpart exists in the private part -- of the package, and emit an error for each that lacks one. + procedure Inspect_Components_Needing_Construction (Pkg_Id : Entity_Id); + -- For each record type declared in package Id that does not require + -- a constructor, report an error on components that have a type that + -- requires explicit constructor initialization (that is, a type that + -- needs construction which has no default parameterless constructor + -- and no default initialization expression). + procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id); -- Given the package entity of a generic package instantiation or -- formal package whose corresponding generic is a child unit, installs @@ -1458,9 +1465,10 @@ package body Sem_Ch7 is -- Inspect_Abstract_Constructors_Completion -- ---------------------------------------------- - procedure Inspect_Abstract_Constructors_Completion (Id : Entity_Id) is - First_Priv : constant Entity_Id := First_Private_Entity (Id); - Vis_E : Entity_Id := First_Entity (Id); + procedure Inspect_Abstract_Constructors_Completion (Pkg_Id : Entity_Id) + is + First_Priv : constant Entity_Id := First_Private_Entity (Pkg_Id); + Vis_E : Entity_Id := First_Entity (Pkg_Id); begin while Present (Vis_E) and then Vis_E /= First_Priv loop @@ -1498,6 +1506,51 @@ package body Sem_Ch7 is end loop; end Inspect_Abstract_Constructors_Completion; + --------------------------------------------- + -- Inspect_Components_Needing_Construction -- + --------------------------------------------- + + procedure Inspect_Components_Needing_Construction (Pkg_Id : Entity_Id) is + Comp_Decl : Node_Id; + Comp_Id : Entity_Id; + Comp_Typ : Entity_Id; + E : Entity_Id; + + begin + E := First_Entity (Pkg_Id); + + while Present (E) loop + if Is_Record_Type (E) + and then not Needs_Construction (E) + and then Comes_From_Source (E) + and then not Is_Class_Wide_Type (E) + and then Nkind (Parent (E)) = N_Full_Type_Declaration + then + Comp_Decl := First_Component_Declaration (E); + + while Present (Comp_Decl) loop + if Nkind (Comp_Decl) = N_Component_Declaration then + Comp_Id := Defining_Identifier (Comp_Decl); + Comp_Typ := Etype (Comp_Id); + + if Needs_Construction (Comp_Typ) + and then not Has_Parameterless_Constructor (Comp_Typ) + and then No (Expression (Comp_Decl)) + then + Error_Msg_NE + ("& needs explicit constructor call", + Comp_Id, Comp_Id); + end if; + end if; + + Next_Non_Pragma (Comp_Decl); + end loop; + end if; + + Next_Entity (E); + end loop; + end Inspect_Components_Needing_Construction; + ---------------------------------------- -- Inspect_Unchecked_Union_Completion -- ---------------------------------------- @@ -1945,6 +1998,7 @@ package body Sem_Ch7 is if Core_Extensions_Allowed then Inspect_Abstract_Constructors_Completion (Id); + Inspect_Components_Needing_Construction (Id); end if; E := First_Entity (Id); diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 4c56f906c3ce..d8bf6f0608f7 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -14215,6 +14215,42 @@ package body Sem_Util is return Name_Find; end Add_Suffix; + --------------------------------- + -- First_Component_Declaration -- + --------------------------------- + + function First_Component_Declaration (Typ : Entity_Id) return Node_Id is + Type_Def : Node_Id; + Comp_List : Node_Id := Empty; + + begin + pragma Assert (Is_Record_Type (Typ) + and then Nkind (Parent (Typ)) = N_Full_Type_Declaration); + + Type_Def := Type_Definition (Parent (Typ)); + + -- Locate the non-inherited component list: the record extension part + -- for a derived type, the type definition for a non-derived one. + + if Is_Derived_Type (Typ) then + if Nkind (Type_Def) = N_Derived_Type_Definition + and then Present (Record_Extension_Part (Type_Def)) + then + Comp_List := Component_List (Record_Extension_Part (Type_Def)); + end if; + + else + pragma Assert (Nkind (Type_Def) = N_Record_Definition); + Comp_List := Component_List (Type_Def); + end if; + + if Present (Comp_List) then + return First_Non_Pragma (Component_Items (Comp_List)); + else + return Empty; + end if; + end First_Component_Declaration; + ------------------- -- Remove_Suffix -- ------------------- diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 97a219c88e89..c10900e8c7a3 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -3185,6 +3185,16 @@ package Sem_Util is -- Inherit predicate functions and Has_Predicates flag from type From_Typ. -- Typ is the destination type. + function First_Component_Declaration (Typ : Entity_Id) return Node_Id; + -- Return the first non-pragma component declaration among the + -- non-inherited (own) components of record type Typ, or Empty when Typ + -- has no own component list or that list is empty. For a derived record + -- type the own components are those of the record extension part; for a + -- non-derived record type they are those of its type definition. Iterate + -- over the remaining own component declarations with Next_Non_Pragma. The + -- caller must ensure that Typ is a record type and Parent (Typ) is an + -- N_Full_Type_Declaration. + procedure Record_Possible_Part_Of_Reference (Var_Id : Entity_Id; Ref : Node_Id);
