From: Denis Mazzucato <[email protected]>
An implicit parameterless constructor is available when no other constructor is
declared for a tagged type that has an ancestor with constructors. The implicit
parameterless constructor calls the parent parameterless constructor through the
Super aspect without arguments.
gcc/ada/ChangeLog:
* aspects.ads (Aspects): Make Super aspect optional to allow for
explicit call to parent parameterless constructor.
* exp_ch3.adb (Build_Implicit_Parameterless_Constructor): Build implicit
parameterless constructor when no other constructors are defined but the
type has an ancestor with constructors.
* exp_ch6.adb
(Init_Expression_If_Any): Pe4rmit implicit calls to parameterless
constructors in initialization expressions if available.
(Make_Parent_Constructor_Call): Super without parameters calls the
parent parameterless constructor.
* sem_ch13.adb (Analyze_Aspect_Specification): Allow Super aspect
without expression.
* sem_ch3.adb (Analyze_Object_Declaration): Delay check for missing
parameterless constructor until the the implicit constructor is built.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.ads | 2 +-
gcc/ada/exp_ch3.adb | 84 +++++++++++++++++++++++++++++++++++++++++---
gcc/ada/exp_ch6.adb | 31 ++++++++++++++--
gcc/ada/sem_ch13.adb | 74 ++++++++++++++++++++------------------
gcc/ada/sem_ch3.adb | 9 -----
5 files changed, 148 insertions(+), 52 deletions(-)
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 9e01abf233f..7b127751ec0 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -524,7 +524,7 @@ package Aspects is
Aspect_Stream_Size => Expression,
Aspect_String_Literal => Name,
Aspect_Subprogram_Variant => Expression,
- Aspect_Super => Expression,
+ Aspect_Super => Optional_Expression,
Aspect_Suppress => Name,
Aspect_Synchronization => Name,
Aspect_Test_Case => Expression,
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 13cf7bad88c..3aa86247f14 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -95,9 +95,14 @@ package body Exp_Ch3 is
-- It also supplies the source location used for the procedure.
procedure Build_Implicit_Copy_Constructor (N : Node_Id; Typ : Entity_Id);
- -- Build default copy constructor. N is the type declaration node, and Typ
+ -- Build implicit copy constructor. N is the type declaration node, and Typ
-- is the corresponding entity for the record type.
+ procedure Build_Implicit_Parameterless_Constructor
+ (N : Node_Id; Typ : Entity_Id);
+ -- Build implicit parameterless constructor. N is the type declaration
+ -- node, and Typ is the corresponding entity for the record type.
+
function Build_Discriminant_Formals
(Rec_Id : Entity_Id;
Use_Dl : Boolean) return List_Id;
@@ -1982,6 +1987,74 @@ package body Exp_Ch3 is
Set_Init_Proc (Typ, Copy_Id);
end Build_Implicit_Copy_Constructor;
+ ----------------------------------------------
+ -- Build_Implicit_Parameterless_Constructor --
+ ----------------------------------------------
+
+ procedure Build_Implicit_Parameterless_Constructor
+ (N : Node_Id; Typ : Entity_Id)
+ is
+ Loc : constant Source_Ptr := Sloc (Typ);
+ Constructor_Id : Entity_Id;
+ Spec_Node : Node_Id;
+ begin
+ -- The implicit parameterless constructor doesn't need to do anything.
+ -- In fact, during subprogram expansion, prepending the prologue of
+ -- constructors takes care of calling the parent's constructor (if
+ -- derived) and initializing components that need construction. Exactly
+ -- what an implicit parameterless constructor should do.
+
+ if not Comes_From_Source (N)
+ or else not Needs_Construction (Typ)
+ or else Has_Parameterless_Constructor (Typ, Allow_Removed => True)
+ or else Has_Explicit_Constructor (Typ)
+ or else (Is_Derived_Type (Typ)
+ and then not Has_Parameterless_Constructor
+ (Parent_Subtype (Typ)))
+ then
+ return;
+ end if;
+
+ Constructor_Id :=
+ Make_Defining_Identifier (Loc,
+ Direct_Attribute_Definition_Name (Typ, Name_Constructor));
+ Mutate_Ekind (Constructor_Id, E_Procedure);
+
+ if not Debug_Generated_Code then
+ Set_Debug_Info_Off (Constructor_Id);
+ end if;
+
+ Spec_Node := New_Node (N_Procedure_Specification, Loc);
+ Set_Defining_Unit_Name (Spec_Node, Constructor_Id);
+
+ -- The implicit parameterless constructor has the following profile:
+ -- procedure T'Constructor (Self : in out T);
+
+ Set_Parameter_Specifications (Spec_Node, New_List (
+ Make_Parameter_Specification (Loc,
+ Defining_Identifier => Make_Defining_Identifier (Loc, Name_Self),
+ In_Present => True,
+ Out_Present => True,
+ Parameter_Type => New_Occurrence_Of (Typ, Loc))));
+
+ Freeze_Extra_Formals (Constructor_Id);
+
+ declare
+ Ignore : Node_Id;
+ begin
+ Ignore :=
+ Make_Subprogram_Body (Loc,
+ Specification => Spec_Node,
+ Handled_Statement_Sequence =>
+ Make_Handled_Sequence_Of_Statements (Loc));
+ end;
+
+ Set_Is_Public (Constructor_Id, Is_Public (Typ));
+ Set_Is_Internal (Constructor_Id);
+ Set_Is_Constructor (Constructor_Id);
+ Set_Init_Proc (Typ, Constructor_Id);
+ end Build_Implicit_Parameterless_Constructor;
+
--------------------------------
-- Build_Discriminant_Formals --
--------------------------------
@@ -6583,10 +6656,6 @@ package body Exp_Ch3 is
Build_Untagged_Record_Equality (Typ);
end if;
- -- Freeze constructors as predefined operations
-
- Append_Freeze_Actions (Typ, Constructor_Freeze (Typ));
-
-- Before building the record initialization procedure, if we are
-- dealing with a concurrent record value type, then we must go through
-- the discriminants, exchanging discriminals between the concurrent
@@ -6631,9 +6700,14 @@ package body Exp_Ch3 is
and then (Tagged_Type_Expansion or else not Is_Interface (Typ))
then
Build_Record_Init_Proc (Typ_Decl, Typ);
+ Build_Implicit_Parameterless_Constructor (Typ_Decl, Typ);
Build_Implicit_Copy_Constructor (Typ_Decl, Typ);
end if;
+ -- Freeze constructors as done with predefined operations
+
+ Append_Freeze_Actions (Typ, Constructor_Freeze (Typ));
+
-- Create the body of TSS primitive Finalize_Address. This must be done
-- before the bodies of all predefined primitives are created. If Typ
-- is limited, Stream_Input and Stream_Read may produce build-in-place
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 70b5a66ed13..8b5e0e4bb98 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -6409,10 +6409,26 @@ package body Exp_Ch6 is
Next (Initialize_Comp_Assoc);
end loop;
+ -- If a default expression is present in the record
+ -- declaration, then use it.
+
if Present (Expression (Parent (Component))) then
return Expression (Parent (Component));
end if;
+ -- In case the type needs construction and a parameterless
+ -- constructor is present, then it can be implicitly used it
+ -- here.
+
+ if Needs_Construction (Etype (Component))
+ and then Has_Parameterless_Constructor (Etype (Component))
+ then
+ return Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (Etype (Component), Loc),
+ Attribute_Name => Name_Make);
+ end if;
+
return Empty;
end Init_Expression_If_Any;
@@ -6466,10 +6482,17 @@ package body Exp_Ch6 is
Expression (Super_Aspect);
Expr : Node_Id;
begin
- if Nkind (Super_Expr) /= N_Aggregate then
+ -- Super without expression is a call to the parent
+ -- parameterless constructor.
+
+ if No (Super_Expr) then
+ Actual_Parameters := No_List;
+
+ elsif Nkind (Super_Expr) /= N_Aggregate then
Expr := New_Copy_Tree (Super_Expr);
Set_Paren_Count (Expr, 0);
Actual_Parameters := New_List (Expr);
+
else
-- Interpret this "aggregate" as a list of
-- actual parameter expressions.
@@ -6509,7 +6532,11 @@ package body Exp_Ch6 is
end if;
if Chars (Component) = Name_uTag then
- null;
+ Append_To (Init_List,
+ Make_Tag_Assignment_From_Type (Loc,
+ Target => New_Occurrence_Of
+ (First_Formal (Spec_Id), Loc),
+ Typ => First_Param_Type));
elsif Chars (Component) = Name_uParent
and then Needs_Construction (Etype (Component))
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index c3cdeeff59b..c72fd6bd8b5 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -5346,48 +5346,52 @@ package body Sem_Ch13 is
Error_Msg_N ("Super must apply to a constructor body", N);
end if;
- -- handle missing parameter list (an error case)
+ -- Without parameter list, the parent parameterless
+ -- constructor is called, nothing more to do here.
- if No (Expr) then
- Error_Msg_N ("constructor parameters required", N);
+ if Present (Expr) then
- -- Handle parameter list of length more than one
- -- (such a list is parsed as an aggregate).
+ -- Handle parameter list of length more than one
+ -- (such a list is parsed as an aggregate).
- elsif Nkind (Expr) = N_Aggregate then
- if Present (Component_Associations (Expr))
- or else No (Expressions (Expr))
- then
+ if Nkind (Expr) = N_Aggregate then
+ if Present (Component_Associations (Expr))
+ or else No (Expressions (Expr))
+ then
+ Error_Msg_N
+ ("malformed constructor parameter list", N);
+
+ elsif Analyze_Parameter_Expressions then
+ declare
+ Param_Expr : Node_Id :=
+ First (Expressions (Expr));
+ begin
+ while Present (Param_Expr) loop
+ Analyze (Param_Expr);
+ Check_Super_Arg (Param_Expr);
+ Next (Param_Expr);
+ end loop;
+
+ Set_Analyzed (Expr);
+ -- Someday Vast may complain that this so-called
+ -- aggregate has no Etype. For now, we mark it
+ -- as analyzed and hope that nobody trips over
+ -- it.
+ end;
+ end if;
+
+ -- handle parameter list of length one
+
+ elsif Paren_Count (Expr) = 0 then
Error_Msg_N
- ("malformed constructor parameter list", N);
+ ("parentheses missing for constructor parameter " &
+ "list ",
+ N);
elsif Analyze_Parameter_Expressions then
- declare
- Param_Expr : Node_Id := First (Expressions (Expr));
- begin
- while Present (Param_Expr) loop
- Analyze (Param_Expr);
- Check_Super_Arg (Param_Expr);
- Next (Param_Expr);
- end loop;
-
- Set_Analyzed (Expr);
- -- Someday Vast may complain that this so-called
- -- aggregate has no Etype. For now, we mark it
- -- as analyzed and hope that nobody trips over it.
- end;
+ Analyze (Expr);
+ Check_Super_Arg (Expr);
end if;
-
- -- handle parameter list of length one
-
- elsif Paren_Count (Expr) = 0 then
- Error_Msg_N
- ("parentheses missing for constructor parameter list ",
- N);
-
- elsif Analyze_Parameter_Expressions then
- Analyze (Expr);
- Check_Super_Arg (Expr);
end if;
end Super;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 63ae1147a4f..b222679f77c 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -5249,15 +5249,6 @@ package body Sem_Ch3 is
and then Nkind (E) = N_Aggregate
then
Act_T := Etype (E);
-
- elsif Needs_Construction (T)
- and then not Has_Init_Expression (N)
- and then not Has_Parameterless_Constructor (T)
- and then not Suppress_Initialization (Id)
- and then Comes_From_Source (N)
- then
- Error_Msg_NE ("no parameterless constructor for&",
- Object_Definition (N), T);
end if;
-- Check No_Wide_Characters restriction
--
2.53.0
