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.
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))
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 :=
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),
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;
-- 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 --
-----------------------------------
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
-- 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;
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;
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
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);
-- 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
-- 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
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 --
----------------------------------------
if Core_Extensions_Allowed then
Inspect_Abstract_Constructors_Completion (Id);
+ Inspect_Components_Needing_Construction (Id);
end if;
E := First_Entity (Id);
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 --
-------------------
-- 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);
projects / thirdparty / gcc.git / commitdiff
