From: Steve Baird <ba...@adacore.com>
Implement the GNAT-defined Super aspect (which should not be confused with
with the Super attribute). For a two-part constructor procedure declaration,
an Initialize aspect specification is permitted on the subprogram body,
and not on the subprogram specification (this reverses was what was previously
implemented). Improve the implementation of the Make attribute.
gcc/ada/ChangeLog:
* aspects.ads: Define Super aspect; allow Initialize aspect
specification on a subprogram body.
* exp_attr.adb (Expand_N_Attribute_Reference): Rewrite Make
attribute implementation.
* exp_ch3.adb (Initialization_Control): Delete Initialization_Mode
and Make_Mode_Literal (those declarations were moved to the spec).
(Build_Record_Init_Proc): For a constructor type, component
initialization (other than for the tag component, if any) must be
performed by calling the single-argument constructor procedure.
(Requires_Init_Proc): Return True for a constructor type.
* exp_ch3.ads (Make_Mode_Literal, Initialization_Mode): New, moved
from the body of this package.
* exp_ch6.adb (Expand_N_Subprogram_Body): Declare, implement, and
call a new local procedure, Prepend_Constructor_Procedure_Prologue
in order to generate component initialization for a constructor
procedure.
* sem_attr.adb (Analyze_Attribute): Improve the error message
generated for a 'Make attribute reference if GNAT extensions are
not all allowed.
* sem_ch13.adb (Analyze_One_Aspect): Improved implementation of
aspect specifications for Initialize, Constructor, and Super
aspects. For Super, there was no previous implementation.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.ads | 9 +-
gcc/ada/exp_attr.adb | 328 +++++--------------------------------------
gcc/ada/exp_ch3.adb | 79 ++++++-----
gcc/ada/exp_ch3.ads | 27 ++++
gcc/ada/exp_ch6.adb | 309 ++++++++++++++++++++++++++++++++++++++++
gcc/ada/sem_attr.adb | 4 +-
gcc/ada/sem_ch13.adb | 109 ++++++++++++--
7 files changed, 519 insertions(+), 346 deletions(-)
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 88fea2e818ce..2871f318b3e5 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -158,6 +158,7 @@ package Aspects is
Aspect_Stream_Size,
Aspect_String_Literal,
Aspect_Subprogram_Variant, -- GNAT
+ Aspect_Super, -- GNAT
Aspect_Suppress,
Aspect_Synchronization,
Aspect_Test_Case, -- GNAT
@@ -518,6 +519,7 @@ package Aspects is
Aspect_Stream_Size => Expression,
Aspect_String_Literal => Name,
Aspect_Subprogram_Variant => Expression,
+ Aspect_Super => Expression,
Aspect_Suppress => Name,
Aspect_Synchronization => Name,
Aspect_Test_Case => Expression,
@@ -626,6 +628,7 @@ package Aspects is
Aspect_Stream_Size => True,
Aspect_String_Literal => False,
Aspect_Subprogram_Variant => False,
+ Aspect_Super => False,
Aspect_Suppress => False,
Aspect_Synchronization => False,
Aspect_Test_Case => False,
@@ -842,6 +845,7 @@ package Aspects is
Aspect_Stream_Size => Name_Stream_Size,
Aspect_String_Literal => Name_String_Literal,
Aspect_Subprogram_Variant => Name_Subprogram_Variant,
+ Aspect_Super => Name_Super,
Aspect_Suppress => Name_Suppress,
Aspect_Suppress_Debug_Info => Name_Suppress_Debug_Info,
Aspect_Suppress_Initialization => Name_Suppress_Initialization,
@@ -1124,6 +1128,7 @@ package Aspects is
Aspect_SPARK_Mode => Never_Delay,
Aspect_Static => Never_Delay,
Aspect_Subprogram_Variant => Never_Delay,
+ Aspect_Super => Never_Delay,
Aspect_Synchronization => Never_Delay,
Aspect_Test_Case => Never_Delay,
Aspect_Unimplemented => Never_Delay,
@@ -1193,10 +1198,12 @@ package Aspects is
-- Sem_Prag.
Aspect_On_Body_Or_Stub_OK : constant array (Aspect_Id) of Boolean :=
- (Aspect_Refined_Depends => True,
+ (Aspect_Initialize => True,
+ Aspect_Refined_Depends => True,
Aspect_Refined_Global => True,
Aspect_Refined_Post => True,
Aspect_SPARK_Mode => True,
+ Aspect_Super => True,
Aspect_Warnings => True,
others => False);
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 7fc104d173bc..a7255da90180 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -24,7 +24,6 @@
------------------------------------------------------------------------------
with Accessibility; use Accessibility;
-with Aspects; use Aspects;
with Atree; use Atree;
with Checks; use Checks;
with Debug; use Debug;
@@ -5113,310 +5112,57 @@ package body Exp_Attr is
when Attribute_Make =>
declare
- Params : List_Id;
- Param : Node_Id;
- Par : Node_Id;
- Construct : Entity_Id;
- Obj : Node_Id := Empty;
- Make_Expr : Node_Id := N;
-
- Formal : Entity_Id;
- Replace_Expr : Node_Id;
- Init_Param : Node_Id;
- Construct_Call : Node_Id;
- Curr_Nam : Node_Id := Empty;
-
- function Replace_Formal_Ref
- (N : Node_Id) return Traverse_Result;
-
- function Replace_Formal_Ref
- (N : Node_Id) return Traverse_Result is
- begin
- if Is_Entity_Name (N)
- and then Chars (Formal) = Chars (N)
- then
- Rewrite (N,
- New_Copy_Tree (Replace_Expr));
- end if;
-
- return OK;
- end Replace_Formal_Ref;
-
- procedure Search_And_Replace_Formal is new
- Traverse_Proc (Replace_Formal_Ref);
-
+ Constructor_Params : List_Id := New_Copy_List (Expressions (N));
+ Constructor_Call : Node_Id;
+ Constructor_EWA : Node_Id;
+ Result_Decl : Node_Id;
+ Result_Id : constant Entity_Id :=
+ Make_Temporary (Loc, 'D', N);
begin
- -- Remove side effects for constructor call
-
- Param := First (Expressions (N));
- while Present (Param) loop
- if Nkind (Param) = N_Parameter_Association then
- Remove_Side_Effects (Explicit_Actual_Parameter (Param),
- Check_Side_Effects => False);
- else
- Remove_Side_Effects (Param, Check_Side_Effects => False);
- end if;
-
- Next (Param);
- end loop;
-
- -- Construct the parameters list
-
- Params := New_Copy_List (Expressions (N));
- if Is_Empty_List (Params) then
- Params := New_List;
+ if Is_Empty_List (Constructor_Params) then
+ Constructor_Params := New_List;
end if;
- -- Identify the enclosing parent for the non-copy cases
+ Result_Decl := Make_Object_Declaration (Loc,
+ Defining_Identifier => Result_Id,
+ Object_Definition =>
+ New_Occurrence_Of (Typ, Loc));
- Par := Parent (N);
- if Nkind (Par) = N_Qualified_Expression then
- Par := Parent (Par);
- Make_Expr := Par;
- end if;
- if Nkind (Par) = N_Allocator then
- Par := Parent (Par);
- Curr_Nam := Make_Explicit_Dereference
- (Loc, Prefix => Empty);
- Obj := Curr_Nam;
- end if;
+ -- Suppress default initialization for result object.
+ -- Default init (except for tag, if tagged) will instead be
+ -- performed in the constructor procedure.
+
+ Mutate_Ekind (Result_Id, E_Variable);
+ Set_Suppress_Initialization (Result_Id);
+
+ -- Build a prefixed-notation call
declare
- Base_Obj : Node_Id := Empty;
- Typ_Comp : Entity_Id;
- Agg_Comp : Entity_Id;
- Comp_Nam : Node_Id := Empty;
+ Proc_Name : constant Node_Id :=
+ Make_Selected_Component (Loc,
+ Prefix => New_Occurrence_Of (Result_Id, Loc),
+ Selector_Name => Make_Identifier (Loc,
+ Chars (Constructor_Name (Typ))));
begin
- while Nkind (Par) not in N_Object_Declaration
- | N_Assignment_Statement
- loop
- if Nkind (Par) = N_Aggregate then
- Typ_Comp := First_Entity (Etype (Par));
- Agg_Comp := First (Expressions (Par));
- loop
- if No (Agg_Comp) then
- return;
- end if;
+ Set_Is_Prefixed_Call (Proc_Name);
- if Agg_Comp = Make_Expr then
- Comp_Nam :=
- Make_Selected_Component (Loc,
- Prefix => Empty,
- Selector_Name =>
- New_Occurrence_Of (Typ_Comp, Loc));
-
- Make_Expr := Parent (Make_Expr);
- Par := Parent (Par);
- exit;
- end if;
-
- Next_Entity (Typ_Comp);
- Next (Agg_Comp);
- end loop;
- elsif Nkind (Par) = N_Component_Association then
- Comp_Nam :=
- Make_Selected_Component (Loc,
- Prefix => Empty,
- Selector_Name =>
- Make_Identifier (Loc,
- (Chars (First (Choices (Par))))));
-
- Make_Expr := Parent (Parent (Make_Expr));
- Par := Parent (Parent (Par));
- else
- declare
- Temp : constant Entity_Id :=
- Make_Temporary (Loc, 'T', N);
- begin
- Rewrite (N,
- Make_Expression_With_Actions (Loc,
- Actions => New_List (
- Make_Object_Declaration (Loc,
- Defining_Identifier => Temp,
- Object_Definition =>
- New_Occurrence_Of (Typ, Loc),
- Expression =>
- New_Copy_Tree (N))),
- Expression => New_Occurrence_Of (Temp, Loc)));
- Analyze_And_Resolve (N);
- return;
- end;
- end if;
-
- if No (Curr_Nam) then
- Curr_Nam := Comp_Nam;
- Obj := Curr_Nam;
- elsif Has_Prefix (Curr_Nam) then
- Set_Prefix (Curr_Nam, Comp_Nam);
- Curr_Nam := Comp_Nam;
- end if;
- end loop;
-
- Base_Obj := (case Nkind (Par) is
- when N_Assignment_Statement =>
- New_Copy_Tree (Name (Par)),
- when N_Object_Declaration =>
- New_Occurrence_Of
- (Defining_Identifier (Par), Loc),
- when others => (raise Program_Error));
-
- if Present (Curr_Nam) then
- Set_Prefix (Curr_Nam, Base_Obj);
- else
- Obj := Base_Obj;
- end if;
+ Constructor_Call := Make_Procedure_Call_Statement (Loc,
+ Parameter_Associations => Constructor_Params,
+ Name => Proc_Name);
end;
- Prepend_To (Params, Obj);
+ Set_Is_Expanded_Constructor_Call (Constructor_Call, True);
- -- Find the constructor we are interested in by doing a
- -- pseudo-pass to resolve the constructor call.
+ Constructor_EWA :=
+ Make_Expression_With_Actions (Loc,
+ Actions => New_List (Result_Decl, Constructor_Call),
+ Expression => New_Occurrence_Of (Result_Id, Loc));
- declare
- Dummy_Params : List_Id := New_Copy_List (Expressions (N));
- Dummy_Self : Node_Id;
- Dummy_Block : Node_Id;
- Dummy_Call : Node_Id;
- Dummy_Id : Entity_Id := Make_Temporary (Loc, 'D', N);
- begin
- if Is_Empty_List (Dummy_Params) then
- Dummy_Params := New_List;
- end if;
-
- Dummy_Self := Make_Object_Declaration (Loc,
- Defining_Identifier => Dummy_Id,
- Object_Definition =>
- New_Occurrence_Of (Typ, Loc));
- Prepend_To (Dummy_Params, New_Occurrence_Of (Dummy_Id, Loc));
-
- Dummy_Call := Make_Procedure_Call_Statement (Loc,
- Parameter_Associations => Dummy_Params,
- Name =>
- (if not Has_Prefix (Pref) then
- Make_Identifier (Loc,
- Chars (Constructor_Name (Typ)))
- else
- Make_Expanded_Name (Loc,
- Chars =>
- Chars (Constructor_Name (Typ)),
- Prefix =>
- New_Copy_Tree (Prefix (Pref)),
- Selector_Name =>
- Make_Identifier (Loc,
- Chars (Constructor_Name (Typ))))));
- Set_Is_Expanded_Constructor_Call (Dummy_Call, True);
-
- Dummy_Block := Make_Block_Statement (Loc,
- Declarations => New_List (Dummy_Self),
- Handled_Statement_Sequence =>
- Make_Handled_Sequence_Of_Statements (Loc,
- Statements => New_List (Dummy_Call)));
-
- Expander_Active := False;
-
- Insert_After_And_Analyze
- (Enclosing_Declaration_Or_Statement (Par), Dummy_Block);
-
- Expander_Active := True;
-
- -- Finally, we can get the constructor based on our pseudo-pass
-
- Construct := Entity (Name (Dummy_Call));
-
- -- Replace the Typ'Make attribute with an aggregate featuring
- -- then relevant aggregate from the correct constructor's
- -- Inializeaspect if it is present - otherwise, simply use a
- -- box.
-
- if Has_Aspect (Construct, Aspect_Initialize) then
- Rewrite (N,
- New_Copy_Tree
- (Find_Value_Of_Aspect (Construct, Aspect_Initialize)));
-
- Param := Next (First (Params));
- Formal := Next_Entity (First_Entity (Construct));
- while Present (Param) loop
- if Nkind (Param) = N_Parameter_Association then
- Formal := Selector_Name (Param);
- Replace_Expr := Explicit_Actual_Parameter (Param);
- else
- Replace_Expr := Param;
- end if;
-
- Init_Param := First (Component_Associations (N));
- while Present (Init_Param) loop
- Search_And_Replace_Formal (Expression (Init_Param));
-
- Next (Init_Param);
- end loop;
-
- if Nkind (Param) /= N_Parameter_Association then
- Next_Entity (Formal);
- end if;
- Next (Param);
- end loop;
-
- Init_Param := First (Component_Associations (N));
- while Present (Init_Param) loop
- if Nkind (Expression (Init_Param)) = N_Attribute_Reference
- and then Attribute_Name
- (Expression (Init_Param)) = Name_Make
- then
- Insert_After (Par,
- Make_Assignment_Statement (Loc,
- Name =>
- Make_Selected_Component (Loc,
- Prefix =>
- New_Copy_Tree (First (Params)),
- Selector_Name =>
- Make_Identifier (Loc,
- Chars (First (Choices (Init_Param))))),
- Expression =>
- New_Copy_Tree (Expression (Init_Param))));
-
- Rewrite (Expression (Init_Param),
- Make_Aggregate (Loc,
- Expressions => New_List,
- Component_Associations => New_List (
- Make_Component_Association (Loc,
- Choices =>
- New_List (Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True))));
- end if;
-
- Next (Init_Param);
- end loop;
- else
- Rewrite (N,
- Make_Aggregate (Loc,
- Expressions => New_List,
- Component_Associations => New_List (
- Make_Component_Association (Loc,
- Choices => New_List (Make_Others_Choice (Loc)),
- Expression => Empty,
- Box_Present => True))));
- end if;
-
- -- Rewrite this block to be null and pretend it didn't happen
-
- Rewrite (Dummy_Block, Make_Null_Statement (Loc));
- end;
-
- Analyze_And_Resolve (N, Typ);
-
- -- Finally, insert the constructor call
-
- Construct_Call :=
- Make_Procedure_Call_Statement (Loc,
- Name =>
- New_Occurrence_Of (Construct, Loc),
- Parameter_Associations => Params);
-
- Set_Is_Expanded_Constructor_Call (Construct_Call);
- Insert_After (Par, Construct_Call);
+ Rewrite (N, Constructor_EWA);
end;
+ Analyze_And_Resolve (N, Typ);
+
--------------
-- Mantissa --
--------------
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 07cb4eb84de8..d5dfc5d20944 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -75,7 +75,6 @@ with Sinfo.Nodes; use Sinfo.Nodes;
with Sinfo.Utils; use Sinfo.Utils;
with Stand; use Stand;
with Snames; use Snames;
-with Tbuild; use Tbuild;
with Ttypes; use Ttypes;
with Validsw; use Validsw;
with Warnsw; use Warnsw;
@@ -211,32 +210,6 @@ package body Exp_Ch3 is
-- component that requires late initialization; this includes
-- components of ancestor types.
- type Initialization_Mode is
- (Full_Init, Full_Init_Except_Tag, Early_Init_Only, Late_Init_Only);
- -- The initialization routine for a tagged type is passed in a
- -- formal parameter of this type, indicating what initialization
- -- is to be performed. This parameter defaults to Full_Init in all
- -- cases except when the init proc of a type extension (let's call
- -- that type T2) calls the init proc of its parent (let's call that
- -- type T1). In that case, one of the other 3 values will
- -- be passed in. In all three of those cases, the Tag component has
- -- already been initialized before the call and is therefore not to be
- -- modified. T2's init proc will either call T1's init proc
- -- once (with Full_Init_Except_Tag as the parameter value) or twice
- -- (first with Early_Init_Only, then later with Late_Init_Only),
- -- depending on the result returned by Has_Late_Init_Component (T1).
- -- In the latter case, the first call does not initialize any
- -- components that require late initialization and the second call
- -- then performs that deferred initialization.
- -- Strictly speaking, the formal parameter subtype is actually Natural
- -- but calls will only pass in values corresponding to literals
- -- of this enumeration type.
-
- function Make_Mode_Literal
- (Loc : Source_Ptr; Mode : Initialization_Mode) return Node_Id
- is (Make_Integer_Literal (Loc, Initialization_Mode'Pos (Mode)));
- -- Generate an integer literal for a given mode value.
-
function Tag_Init_Condition
(Loc : Source_Ptr;
Init_Control_Formal : Entity_Id) return Node_Id;
@@ -2481,14 +2454,10 @@ package body Exp_Ch3 is
and then Nkind (Id_Ref) = N_Selected_Component
and then Chars (Selector_Name (Id_Ref)) = Name_uParent
then
- declare
- use Initialization_Control;
- begin
- Append_To (Args,
- (if Present (Init_Control_Actual)
- then Init_Control_Actual
- else Make_Mode_Literal (Loc, Full_Init_Except_Tag)));
- end;
+ Append_To (Args,
+ (if Present (Init_Control_Actual)
+ then Init_Control_Actual
+ else Make_Mode_Literal (Loc, Full_Init_Except_Tag)));
elsif Present (Constructor_Ref) then
Append_List_To (Args,
New_Copy_List (Parameter_Associations (Constructor_Ref)));
@@ -3216,6 +3185,40 @@ package body Exp_Ch3 is
if Parent_Subtype_Renaming_Discrims then
Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters));
+ elsif Present (Constructor_Name (Rec_Type)) then
+ if Present (Default_Constructor (Rec_Type)) then
+ -- The 'Make attribute reference (with no arguments) will
+ -- generate a call to the one-parameter constructor procedure.
+
+ Append_To (Body_Stmts,
+ Make_Assignment_Statement (Loc,
+ Name => New_Occurrence_Of
+ (Defining_Identifier (First (Parameters)), Loc),
+ Expression => Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Rec_Type, Loc),
+ Attribute_Name => Name_Make)));
+ else
+ -- No constructor procedure with an appropriate profile
+ -- is available, so raise Program_Error.
+ --
+ -- We could instead do nothing here, since the absence of a
+ -- one-parameter constructor procedure should trigger other
+ -- legality checks which should statically ensure that
+ -- the init proc we are constructing here will never be
+ -- called. So a bit of "belt and suspenders" here.
+ -- If this raise statement is ever executed, that probably
+ -- means that some compile-time legality check is not
+ -- implemented, and that the program should have instead
+ -- failed to compile.
+ -- Because this raise statement should never be executed, it
+ -- seems ok to pass in a dubious Reason parameter instead of
+ -- declaring a new RT_Exception_Code value.
+
+ Append_To (Body_Stmts,
+ Make_Raise_Program_Error (Loc,
+ Reason => PE_Explicit_Raise));
+ end if;
+
elsif Nkind (Type_Definition (N)) = N_Record_Definition then
Build_Discriminant_Assignments (Body_Stmts);
@@ -3310,7 +3313,7 @@ package body Exp_Ch3 is
end if;
end if;
- -- Add here the assignment to instantiate the Tag
+ -- Add here the assignment to initialize the Tag
-- The assignment corresponds to the code:
@@ -4170,7 +4173,6 @@ package body Exp_Ch3 is
if Present (Parent_Id) then
declare
Parent_Loc : constant Source_Ptr := Sloc (Parent (Parent_Id));
- use Initialization_Control;
begin
-- We are building the init proc for a type extension.
-- Call the parent type's init proc a second time, this
@@ -4558,6 +4560,8 @@ package body Exp_Ch3 is
-- since the call is generated, there had better be a routine
-- at the other end of the call, even if it does nothing).
+ -- 10. The type has a specified Constructor aspect.
+
-- Note: the reason we exclude the CPP_Class case is because in this
-- case the initialization is performed by the C++ constructors, and
-- the IP is built by Set_CPP_Constructors.
@@ -4573,6 +4577,7 @@ package body Exp_Ch3 is
or else Is_Tagged_Type (Rec_Id)
or else Is_Concurrent_Record_Type (Rec_Id)
or else Has_Task (Rec_Id)
+ or else Present (Constructor_Name (Rec_Id))
then
return True;
end if;
diff --git a/gcc/ada/exp_ch3.ads b/gcc/ada/exp_ch3.ads
index 0b0a2b68642c..69e6cb4ba352 100644
--- a/gcc/ada/exp_ch3.ads
+++ b/gcc/ada/exp_ch3.ads
@@ -27,6 +27,7 @@
with Elists; use Elists;
with Exp_Tss; use Exp_Tss;
+with Tbuild; use Tbuild;
with Types; use Types;
with Uintp; use Uintp;
@@ -194,6 +195,32 @@ package Exp_Ch3 is
-- initialized; if Variable_Comps is True then tags components located at
-- variable positions of Target are initialized.
+ type Initialization_Mode is
+ (Full_Init, Full_Init_Except_Tag, Early_Init_Only, Late_Init_Only);
+ -- The initialization routine for a tagged type is passed in a
+ -- formal parameter of this type, indicating what initialization
+ -- is to be performed. This parameter defaults to Full_Init in all
+ -- cases except when the init proc of a type extension (let's call
+ -- that type T2) calls the init proc of its parent (let's call that
+ -- type T1). In that case, one of the other 3 values will
+ -- be passed in. In all three of those cases, the Tag component has
+ -- already been initialized before the call and is therefore not to be
+ -- modified. T2's init proc will either call T1's init proc
+ -- once (with Full_Init_Except_Tag as the parameter value) or twice
+ -- (first with Early_Init_Only, then later with Late_Init_Only),
+ -- depending on the result returned by Has_Late_Init_Component (T1).
+ -- In the latter case, the first call does not initialize any
+ -- components that require late initialization and the second call
+ -- then performs that deferred initialization.
+ -- Strictly speaking, the formal parameter subtype is actually Natural
+ -- but calls will only pass in values corresponding to literals
+ -- of this enumeration type.
+
+ function Make_Mode_Literal
+ (Loc : Source_Ptr; Mode : Initialization_Mode) return Node_Id
+ is (Make_Integer_Literal (Loc, Initialization_Mode'Pos (Mode)));
+ -- Generate an integer literal for a given mode value.
+
procedure Make_Controlling_Function_Wrappers
(Tag_Typ : Entity_Id;
Decl_List : out List_Id;
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 1a9002ce3a8b..32e96bed2349 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -6244,6 +6244,15 @@ package body Exp_Ch6 is
-- returns, since they get eliminated anyway later on. Spec_Id denotes
-- the corresponding spec of the subprogram body.
+ procedure Prepend_Constructor_Procedure_Prologue
+ (Spec_Id : Entity_Id; Body_Id : Entity_Id; L : List_Id);
+
+ -- If N is the body of a constructor procedure (that is, a procedure
+ -- named in a Constructor aspect specification for the type of the
+ -- procedure's first parameter), then prepend and analyze the
+ -- associated initialization code for that parameter.
+ -- This has nothing to do with CPP constructors.
+
----------------
-- Add_Return --
----------------
@@ -6317,6 +6326,300 @@ package body Exp_Ch6 is
end if;
end Add_Return;
+ --------------------------------------------
+ -- Prepend_Constructor_Procedure_Prologue --
+ --------------------------------------------
+
+ procedure Prepend_Constructor_Procedure_Prologue
+ (Spec_Id : Entity_Id; Body_Id : Entity_Id; L : List_Id)
+ is
+
+ function First_Param_Type return Entity_Id is
+ (Implementation_Base_Type (Etype (First_Formal (Spec_Id))));
+
+ Is_Constructor_Procedure : constant Boolean :=
+ Nkind (Specification (N)) = N_Procedure_Specification
+ and then Present (First_Formal (Spec_Id))
+ and then Present (Constructor_Name (First_Param_Type))
+ and then Chars (Spec_Id) = Chars (Constructor_Name
+ (First_Param_Type))
+ and then Ekind (First_Formal (Spec_Id)) = E_In_Out_Parameter
+ and then Scope (Spec_Id) = Scope (First_Param_Type);
+ begin
+ if not Is_Constructor_Procedure then
+ return; -- the usual case
+ end if;
+
+ -- Initialize the first parameter.
+ -- First_Param_Type is a record type (tagged or untagged) or
+ -- a type extension. If it is a type extension, then we begin by
+ -- calling the appropriate constructor procedure for the _parent
+ -- part. In the absence of a Super aspect specification, the
+ -- "appropriate" constructor is the one that takes only a single
+ -- parameter (the object being initialized). Additional actual
+ -- parameters for the constructor call may be provided via a
+ -- Super aspect specification, in which case a different
+ -- constructor procedure will be invoked.
+ --
+ -- For each remaining component we first check to see if it
+ -- is mentioned in the Initialize aspect specification (if any) for
+ -- Body_Id. If so, then evaluate the expression given for that
+ -- component in the aspect specification and assign it to the
+ -- given component of the first parameter. If not, and if an
+ -- explicit default initial value is provided for the given component
+ -- in the type declaration, then do the same thing with that
+ -- expression instead. Otherwise perform normal default
+ -- initialization for the component - invoke the init proc for the
+ -- component's type if one exists, and otherwise do nothing.
+
+ -- We do not perform tag initialization here. That is dealt with
+ -- elsewhere. The init proc for a tagged type is
+ -- passed an extra parameter indicating whether to perform
+ -- tag initialization.
+
+ -- In the case of a type (tagged or untagged) that is not
+ -- an extension, we could just generate a single assignment,
+ -- taking the RHS from the Initialize aspect value (which is an
+ -- N_Aggregate node). But that gets complicated in the case of
+ -- an extension, so we handle all cases one component at a time.
+
+ declare
+ Initialize_Aspect : constant Node_Id :=
+ Find_Aspect (Body_Id, Aspect_Initialize);
+
+ First_Initialize_Comp_Assoc : constant Node_Id :=
+ (if Present (Initialize_Aspect)
+ then First (Component_Associations
+ (Expression (Initialize_Aspect)))
+ 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.
+
+ function Make_Init_Proc_Call (Component : Entity_Id;
+ Component_Name : Node_Id)
+ return Node_Id;
+ -- Builds and returns a call to the init proc for the type of
+ -- the component in order to initialize the given component.
+ -- The init proc must exist.
+
+ function Make_Parent_Constructor_Call (Parent_Type : Entity_Id)
+ return Node_Id;
+ -- Builds and returns a call to the appropriate constructor
+ -- procedure of the parent type.
+ -- This function is called only in the case of a
+ -- Constructor procedure for a type extension.
+
+ ----------------------------
+ -- Init_Expression_If_Any --
+ ----------------------------
+
+ function Init_Expression_If_Any (Component : Entity_Id)
+ return Node_Id
+ is
+ Initialize_Comp_Assoc : Node_Id := First_Initialize_Comp_Assoc;
+ Choice : Node_Id;
+
+ -- ??? 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 (Choice) loop
+ if Nkind (Choice) = N_Identifier
+ and then Chars (Choice) = Chars (Component)
+ then
+ return Expression (Initialize_Comp_Assoc);
+ end if;
+ Next (Choice);
+ end loop;
+
+ Next (Initialize_Comp_Assoc);
+ end loop;
+
+ if Present (Expression (Parent (Component))) then
+ return Expression (Parent (Component));
+ end if;
+
+ return Empty;
+ end Init_Expression_If_Any;
+
+ -------------------------
+ -- Make_Init_Proc_Call --
+ -------------------------
+
+ function Make_Init_Proc_Call (Component : Entity_Id;
+ Component_Name : Node_Id)
+ return Node_Id
+ is
+ Params : constant List_Id := New_List (Component_Name);
+ Init_Proc : constant Entity_Id :=
+ Base_Init_Proc (Etype (Component));
+ begin
+ if Is_Tagged_Type (Etype (Component)) then
+ Append (Make_Mode_Literal (Loc, Full_Init), Params);
+ end if;
+
+ return Init_Proc_Call : constant Node_Id :=
+ Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Init_Proc, Loc),
+ Parameter_Associations => Params)
+ do
+ pragma Assert (Check_Number_Of_Actuals
+ (Subp_Call => Init_Proc_Call,
+ Subp_Id => Init_Proc));
+ end return;
+ end Make_Init_Proc_Call;
+
+ ----------------------------------
+ -- Make_Parent_Constructor_Call --
+ ----------------------------------
+
+ function Make_Parent_Constructor_Call (Parent_Type : Entity_Id)
+ return Node_Id
+ is
+ Actual_Parameters : List_Id := No_List;
+ Super_Aspect : constant Node_Id :=
+ Find_Aspect (Body_Id, Aspect_Super);
+
+ -- Do not confuse the Super aspect with the Super attribute.
+ -- Both are referenced here, but they are not related as
+ -- closely as some aspect/attribute homonym pairs are.
+ -- The attribute takes an object as a prefix. The aspect
+ -- can be specified for the body of a constructor procedure.
+ begin
+ if Present (Super_Aspect) then
+ declare
+ Super_Expr : constant Node_Id :=
+ Expression (Super_Aspect);
+ Expr : Node_Id;
+ begin
+ if 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.
+
+ Actual_Parameters := New_List;
+ Expr := First (Expressions (Super_Expr));
+ while Present (Expr) loop
+ Append (New_Copy_Tree (Expr), Actual_Parameters);
+ Next (Expr);
+ end loop;
+ end if;
+ end;
+ end if;
+
+ -- Build a prefixed-notation call
+ declare
+ Proc_Name : constant Node_Id :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of
+ (First_Formal (Spec_Id), Loc),
+ Attribute_Name => Name_Super),
+ Selector_Name =>
+ Make_Identifier (Loc,
+ Chars (Constructor_Name (Parent_Type))));
+ begin
+ Set_Is_Prefixed_Call (Proc_Name);
+
+ return Make_Procedure_Call_Statement (Loc,
+ Name => Proc_Name,
+ Parameter_Associations => Actual_Parameters);
+ end;
+ end Make_Parent_Constructor_Call;
+
+ begin
+ while Present (Component) loop
+ pragma Assert (Ekind (Component) = E_Component);
+
+ if Chars (Component) = Name_uTag then
+ null;
+
+ elsif Chars (Component) = Name_uParent then
+ -- ??? Here is where we should be looking for a
+ -- Super aspect specification in order to call the
+ -- right constructor with the right parameters
+ -- (as opposed to unconditionally calling the
+ -- single-parameter constructor).
+ Append_To (Init_List, Make_Parent_Constructor_Call
+ (Parent_Type => Etype (Component)));
+
+ else
+ declare
+ Maybe_Init_Exp : constant Node_Id :=
+ Init_Expression_If_Any (Component);
+
+ function Make_Component_Name return Node_Id is
+ (Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (First_Formal (Spec_Id), 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
+ -- ??? Should reorganize things so that
+ -- procedure Build_Assignment in exp_ch3.adb
+ -- (which is currently declared inside of
+ -- Build_Record_Init_Proc) can be called from here.
+ -- That procedure handles some corner cases
+ -- that are not properly handled here (e.g.,
+ -- mapping current instance references to the
+ -- appropriate formal parameter).
+
+ if Is_Tagged_Type (Etype (Component)) then
+ Append_To (Init_List,
+ Make_Tag_Assignment_From_Type (Loc,
+ Target => Make_Component_Name,
+ Typ => Etype (Component)));
+ end if;
+
+ Append_To (Init_List,
+ Make_Assignment_Statement (Loc,
+ Name => Make_Component_Name,
+ Expression => New_Copy_Tree
+ (Maybe_Init_Exp,
+ New_Scope => Body_Id)));
+
+ -- Handle case where component's type has an init proc
+ elsif Has_Non_Null_Base_Init_Proc (Etype (Component)) then
+ Append_To (Init_List,
+ Make_Init_Proc_Call (
+ Component => Component,
+ Component_Name => Make_Component_Name));
+ else
+ pragma Assert (not Is_Tagged_Type (Etype (Component)));
+ end if;
+ end;
+ end if;
+
+ Next_Entity (Component);
+ end loop;
+
+ Insert_List_Before_And_Analyze (First (L), Init_List);
+ end;
+ end Prepend_Constructor_Procedure_Prologue;
+
-- Local variables
Except_H : Node_Id;
@@ -6549,6 +6852,12 @@ package body Exp_Ch6 is
Detect_Infinite_Recursion (N, Spec_Id);
end if;
+ -- If the subprogram is a constructor procedure then prepend
+ -- and analyze initialization code.
+
+ Prepend_Constructor_Procedure_Prologue
+ (Spec_Id => Spec_Id, Body_Id => Body_Id, L => L);
+
-- Set to encode entity names in package body before gigi is called
Qualify_Entity_Names (N);
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 2a92ffbce4f3..e08dc42d903d 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -5179,10 +5179,8 @@ package body Sem_Attr is
when Attribute_Make => declare
Expr : Entity_Id;
begin
- -- Should this be assert? Parsing should fail if it hits 'Make
- -- and all extensions aren't enabled ???
-
if not All_Extensions_Allowed then
+ Error_Msg_GNAT_Extension ("Make attribute", Loc);
return;
end if;
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index a4f15ac979c1..2166eb318d75 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -4464,11 +4464,16 @@ package body Sem_Ch13 is
-- Error checking
if not All_Extensions_Allowed then
+ Error_Msg_Name_1 := Nam;
+ Error_Msg_GNAT_Extension ("aspect %", Loc);
goto Continue;
end if;
- if Ekind (E) /= E_Procedure then
- Error_Msg_N ("Initialize must apply to a constructor", N);
+ if Ekind (E) /= E_Subprogram_Body
+ or else Nkind (Parent (E)) /= N_Procedure_Specification
+ then
+ Error_Msg_N
+ ("Initialize must apply to a constructor body", N);
end if;
if Present (Expressions (Expression (Aspect))) then
@@ -4507,11 +4512,6 @@ package body Sem_Ch13 is
Next_Entity (Type_Comp);
end loop;
- -- Push the scope and formals for analysis
-
- Push_Scope (E);
- Install_Formals (Defining_Unit_Name (Specification (N)));
-
-- Analyze the components
Aspect_Comp :=
@@ -4530,10 +4530,6 @@ package body Sem_Ch13 is
Dummy_Aggr := New_Copy_Tree (Expression (Aspect));
Resolve_Aggregate (Dummy_Aggr, Typ);
Expander_Active := True;
-
- -- Return the scope
-
- End_Scope;
end Initialize;
-- Initializes
@@ -5031,6 +5027,12 @@ package body Sem_Ch13 is
goto Continue;
when Aspect_Constructor =>
+ if not All_Extensions_Allowed then
+ Error_Msg_Name_1 := Nam;
+ Error_Msg_GNAT_Extension ("aspect %", Loc);
+ goto Continue;
+ end if;
+
Set_Constructor_Name (E, Expr);
Set_Needs_Construction (E);
@@ -5295,6 +5297,80 @@ package body Sem_Ch13 is
-- generated yet because the evaluation of the boolean needs
-- to be delayed till the freeze point.
+ -- Super
+
+ when Aspect_Super => Super :
+ declare
+ Analyze_Parameter_Expressions : constant Boolean := True;
+ -- ???
+ -- We can analyze actual parameter expressions here (with
+ -- no context, like the operand of a type conversion),
+ -- or leave them unanalyzed for now and catch problems
+ -- when we analyze the generated constructor call
+ -- (where overload resolution may provide context that
+ -- resolves some ambiguities).
+ -- For now, we analyze them here to avoid depending
+ -- on legality checking performed during expansion.
+ -- To reverse this decision, set this flag to False.
+
+ begin
+ -- Error checking
+
+ if not All_Extensions_Allowed then
+ Error_Msg_Name_1 := Nam;
+ Error_Msg_GNAT_Extension ("aspect %", Loc);
+ goto Continue;
+ end if;
+
+ if Ekind (E) /= E_Subprogram_Body
+ or else Nkind (Parent (E)) /= N_Procedure_Specification
+ then
+ Error_Msg_N ("Super must apply to a constructor body", N);
+ end if;
+
+ -- handle missing parameter list (an error case)
+
+ if No (Expr) then
+ Error_Msg_N ("constructor parameters required", N);
+
+ -- 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
+ 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);
+ 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
+ ("parentheses missing for constructor parameter list ",
+ N);
+
+ elsif Analyze_Parameter_Expressions then
+ Analyze (Expr);
+ end if;
+ end Super;
+
when Boolean_Aspects
| Library_Unit_Aspects
=>
@@ -5690,7 +5766,9 @@ package body Sem_Ch13 is
Set_Declarations (N, New_List);
end if;
- Prepend (Aitem, Declarations (N));
+ if Present (Aitem) then
+ Prepend (Aitem, Declarations (N));
+ end if;
elsif Nkind (N) = N_Generic_Package_Declaration then
if No (Visible_Declarations (Specification (N))) then
@@ -5761,7 +5839,9 @@ package body Sem_Ch13 is
-- The pragma is added before source declarations
- Prepend_To (Declarations (N), Aitem);
+ if Present (Aitem) then
+ Prepend_To (Declarations (N), Aitem);
+ end if;
-- When delay is not required and the context is not a compilation
-- unit, we simply insert the pragma/attribute definition clause
@@ -11629,7 +11709,7 @@ package body Sem_Ch13 is
-- Case of stream attributes and Put_Image, just have to compare
-- entities. However, the expression is just a possibly-overloaded
-- name, so we need to verify that one of these interpretations is
- -- the one available at at the freeze point.
+ -- the one available at the freeze point.
elsif A_Id in Aspect_Constructor
| Aspect_Destructor
@@ -12221,6 +12301,7 @@ package body Sem_Ch13 is
| Aspect_Relaxed_Initialization
| Aspect_SPARK_Mode
| Aspect_Subprogram_Variant
+ | Aspect_Super
| Aspect_Suppress
| Aspect_Test_Case
| Aspect_Unimplemented
--
2.43.0
