From: Javier Miranda <[email protected]>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
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 21275bbfe18..d9ab5ee108c 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 0f886a5db56..a2028768c40 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 2709f0eb66a..22317dd9a93 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 4c56f906c3c..d8bf6f0608f 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 97a219c88e8..c10900e8c7a 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);
--
2.53.0
