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.
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));
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)
-- 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;
end if;
return Empty;
- end Init_Expression_If_Any;
+ end Init_From_Default_Or_Constructor;
-------------------------
-- Make_Init_Proc_Call --
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),
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,
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));
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;
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
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;
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;
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.
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
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);
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));
& " 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);
elsif Nkind (First (Choices (Aspect_Comp)))
= N_Others_Choice
then
+ Has_User_Defined_Default := Comes_From_Source (Aspect);
exit;
end if;
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)));
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;
-- 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
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);
-----------------------------------------
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 --
--------------------------
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
projects / thirdparty / gcc.git / commitdiff
