From: Javier Miranda <[email protected]>
This patch extends the currrent support for constructors to support the
initialization of limited types.
gcc/ada/ChangeLog:
* errout.adb (Set_Msg_Node): Improve readability of message for
constructors name, replacing the internal compiler name
generated for direct attribute definitions with a nicer name.
* erroutc.ads (Replace_With_Attribute_Definition): Promote from
a nested subprogram declaration to a public package-level
declaration.
* erroutc.adb (Replace_With_Attribute_Definition): Move its
implementation to package level.
* exp_attr.adb (Expand_N_Attribute_Reference [Attribute_Make]):
Code cleanup; handle assignment statement and limited type
object declaration.
* exp_ch3.adb (Build_Implicit_Parameterless_Constructor): Add
comment.
(Build_Default_Simple_Initialization): Add comment.
* exp_ch4.adb (Expand_N_Allocator): Fix No_Initialization for
internally generated allocators of types with constructors.
* exp_ch6.adb (Prepend_Constructor_Procedure_Prologue): Install
formals and refactor its body to be consistent with the GNAT
style.
* sem_ch3.adb (OK_For_Limited_Init_In_05): Accept T'Make since
it is semantically equivalent to a function call.
* sem_ch6.adb (Analyze_Direct_Attribute_Definition): Handle
incomplete and private type declarations.
* sem_ch13.adb (Diagnose_Misplaced_Aspects): Remove misleading
error for aspect 'Initializes.
* sem_res.adb (Resolve_Actuals): Skip check on the first actual
of init-proc and constructors because the constructor may be
invoked to initialize a constant object, which is allowed.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/errout.adb | 11 +
gcc/ada/erroutc.adb | 78 +++--
gcc/ada/erroutc.ads | 6 +
gcc/ada/exp_attr.adb | 192 ++++++++++---
gcc/ada/exp_ch3.adb | 7 +
gcc/ada/exp_ch4.adb | 9 +-
gcc/ada/exp_ch6.adb | 668 ++++++++++++++++++++++---------------------
gcc/ada/sem_ch13.adb | 17 +-
gcc/ada/sem_ch3.adb | 6 +-
gcc/ada/sem_ch6.adb | 6 +-
gcc/ada/sem_res.adb | 11 +-
11 files changed, 582 insertions(+), 429 deletions(-)
diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb
index 2c427b7515e..cf11a0a6c1c 100644
--- a/gcc/ada/errout.adb
+++ b/gcc/ada/errout.adb
@@ -3853,6 +3853,17 @@ package body Errout is
if Is_Internal_Name then
Kill_Message := True;
end if;
+
+ -- Replace compiler generated name for direct attribute definitions with
+ -- a nicer name.
+
+ if Name_Len > 5
+ and then Name_Buffer (1) = 'D'
+ and then Name_Buffer (Name_Len - 3 .. Name_Len) = "_Att"
+ then
+ Replace_With_Attribute_Definition;
+ end if;
+
-- Remaining step is to adjust casing and possibly add 'Class
Adjust_Name_Case (Global_Name_Buffer, Loc);
diff --git a/gcc/ada/erroutc.adb b/gcc/ada/erroutc.adb
index b46adc18abc..aa2810b5b04 100644
--- a/gcc/ada/erroutc.adb
+++ b/gcc/ada/erroutc.adb
@@ -1448,6 +1448,41 @@ package body Erroutc is
end loop;
end Prescan_Message;
+ ---------------------------------------
+ -- Replace_With_Attribute_Definition --
+ ---------------------------------------
+
+ procedure Replace_With_Attribute_Definition is
+ First : constant Integer := 2;
+ Last : constant Integer := Name_Len - 4;
+ Att_Buf : Bounded_String (Max_Length => Name_Len - 7);
+
+ begin
+ Until_Tick :
+ for J in First .. Last loop
+
+ -- J could be at the position separating the prefix from the
+ -- attribute name.
+
+ if Name_Buffer (J) = '_' then
+ Att_Buf.Length := 0;
+ Append (Att_Buf, Name_Buffer (J + 1 .. Last));
+ Set_Casing (Att_Buf, All_Lower_Case);
+
+ if Is_Direct_Attribute_Definition_Name (Name_Find (Att_Buf)) then
+ Name_Buffer (J) := ''';
+ exit Until_Tick;
+ end if;
+ end if;
+ end loop Until_Tick;
+
+ -- Remove prefix 'D' and suffix "_Att"
+
+ Name_Buffer (1 .. Last - 1) := Name_Buffer (2 .. Last);
+ Name_Len := Last - 1;
+ Set_Casing (All_Lower_Case);
+ end Replace_With_Attribute_Definition;
+
----------------
-- Same_Error --
----------------
@@ -1713,46 +1748,6 @@ package body Erroutc is
----------------------------
procedure Set_Msg_Insertion_Name is
- procedure Replace_With_Attribute_Definition;
- -- This procedure handles direct attribute definition names of the form:
- -- 'D' Prefix_Name "_" Attribute_Name "_Att"
- -- Specifically, it replace the current Namet.Global_Name_Buffer with an
- -- all lowercase string of the prefix, and a tick attribute; at this
- -- stage there is no way to recognize more than an ending attribute ???
- --
- -- Note that, at this point, it is not possible to restore the original
- -- casing thus lowercase is default.a
-
- procedure Replace_With_Attribute_Definition is
- First : constant Integer := 2;
- Last : constant Integer := Name_Len - 4;
- Att_Buf : Bounded_String (Max_Length => Name_Len - 7);
- begin
- Until_Tick :
- for J in First .. Last loop
-
- -- J could be at the position separating the prefix from the
- -- attribute name.
-
- if Name_Buffer (J) = '_' then
- Att_Buf.Length := 0;
- Append (Att_Buf, Name_Buffer (J + 1 .. Last));
- Set_Casing (Att_Buf, All_Lower_Case);
- if Is_Direct_Attribute_Definition_Name (Name_Find (Att_Buf))
- then
- Name_Buffer (J) := ''';
- exit Until_Tick;
- end if;
- end if;
- end loop Until_Tick;
-
- -- Remove prefix 'D' and suffix "_Att"
-
- Name_Buffer (1 .. Last - 1) := Name_Buffer (2 .. Last);
- Name_Len := Last - 1;
- Set_Casing (All_Lower_Case);
- end Replace_With_Attribute_Definition;
-
begin
if Error_Msg_Name_1 = No_Name then
null;
@@ -1798,6 +1793,9 @@ package body Erroutc is
-- Else output with surrounding quotes in proper casing mode
else
+ -- Replace compiler generated name for direct attribute
+ -- definitions with a nicer one.
+
if Name_Buffer (1) = 'D'
and then Name_Buffer (Name_Len - 3 .. Name_Len) = "_Att"
then
diff --git a/gcc/ada/erroutc.ads b/gcc/ada/erroutc.ads
index 2a3f7e3c6bc..039c342d05e 100644
--- a/gcc/ada/erroutc.ads
+++ b/gcc/ada/erroutc.ads
@@ -770,6 +770,12 @@ package Erroutc is
-- Iterate over all of the errors in the error chain and mark all messages
-- as deleted if they match the Filter.
+ procedure Replace_With_Attribute_Definition;
+ -- The caller has placed in Namet.Global_Name_Buffer the internal encoding
+ -- of a direct attribute definition; this subprogram rewrites that name to
+ -- a user-readable T'attribute string. The original source casing cannot
+ -- be recovered from the names table, so the result is all lowercase.
+
function Same_Error (M1, M2 : Error_Msg_Id) return Boolean;
-- See if two messages have the same text. Returns true if the text of the
-- two messages is identical, or if one of them is the same as the other
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index b299dacebfc..aa5d9696804 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -5433,27 +5433,12 @@ package body Exp_Attr is
when Attribute_Make =>
declare
Constructor_Params : List_Id := New_Copy_List (Expressions (N));
- Constructor_Rhs : Node_Id;
- Result_Decl : Node_Id;
- Result_Id : constant Entity_Id :=
- Make_Temporary (Loc, 'D', N);
+
begin
if Is_Empty_List (Constructor_Params) then
Constructor_Params := New_List;
end if;
- Result_Decl := Make_Object_Declaration (Loc,
- Defining_Identifier => Result_Id,
- Object_Definition =>
- New_Occurrence_Of (Typ, Loc));
-
- -- 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);
-
-- A call to the copy constructor can be a special case. Even if
-- no copy constructor is declared (both explicitly by the user or
-- implicitly by the compiler), the call needs to succeed. In this
@@ -5462,45 +5447,168 @@ package body Exp_Attr is
if Is_Copy_Constructor_Call (N)
and then not Has_Copy_Constructor (Entity (Pref))
then
- if Nkind (First (Exprs)) = N_Parameter_Association
- then
- Constructor_Rhs :=
- Relocate_Node (Explicit_Actual_Parameter (First (Exprs)));
+ if Nkind (First (Exprs)) = N_Parameter_Association then
+ Rewrite (N,
+ Relocate_Node
+ (Explicit_Actual_Parameter (First (Exprs))));
else
- Constructor_Rhs := Relocate_Node (First (Exprs));
+ Rewrite (N, Relocate_Node (First (Exprs)));
end if;
+ Analyze_And_Resolve (N, Typ);
+
-- Otherwise build a prefixed-notation call
else
declare
- Constructor_Name : constant Node_Id :=
- Make_Selected_Component (Loc,
- Prefix => New_Occurrence_Of (Result_Id, Loc),
- Selector_Name => Make_Identifier (Loc,
- Direct_Attribute_Definition_Name
- (Typ, Name_Constructor)));
Constructor_Call : Node_Id;
- begin
- Set_Is_Prefixed_Call (Constructor_Name);
- Constructor_Call :=
- Make_Procedure_Call_Statement (Loc,
- Parameter_Associations => Constructor_Params,
- Name => Constructor_Name);
- Set_Is_Expanded_Constructor_Call (Constructor_Call, True);
+ Constructor_Name : Node_Id;
+ Result_Decl : Node_Id;
+ Result_Id : Entity_Id;
- Constructor_Rhs :=
- Make_Expression_With_Actions (Loc,
- Actions => New_List (Result_Decl, Constructor_Call),
- Expression => New_Occurrence_Of (Result_Id, Loc));
+ begin
+ -- Expand Lhs := T'Make (...) into:
+
+ -- Lhs.<Type>_constructor_Att (...)
+
+ if Nkind (Parent (N)) = N_Assignment_Statement then
+ Constructor_Name :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Copy_Tree (Name (Parent (N))),
+ Selector_Name =>
+ Make_Identifier (Loc,
+ Direct_Attribute_Definition_Name (Typ,
+ Name_Constructor)));
+
+ Constructor_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Parameter_Associations => Constructor_Params,
+ Name => Constructor_Name);
+
+ Rewrite (Parent (N), Constructor_Call);
+ Analyze (Parent (N));
+
+ -- Expand Obj : <Type> := T'Make (...), where <Type> T is a
+ -- limited type, into:
+
+ -- Obj : <Type>;
+ -- Obj.<Type>_constructor_Att (...)
+
+ elsif Nkind (Parent (N)) = N_Object_Declaration
+ and then Is_Limited_Type (Ptyp)
+ then
+ Result_Decl := Parent (N);
+ Result_Id := Defining_Identifier (Result_Decl);
+
+ Set_Suppress_Initialization (Result_Id);
+
+ -- For class-wide type object declarations we add a
+ -- view conversion as the prefixed-call prefix so that
+ -- analysis resolves to the specific type constructor.
+
+ if Is_Class_Wide_Type (Etype (Result_Id)) then
+ Constructor_Name :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ Make_Type_Conversion (Loc,
+ Subtype_Mark =>
+ New_Occurrence_Of (Ptyp, Loc),
+ Expression =>
+ New_Occurrence_Of (Result_Id, Loc)),
+ Selector_Name =>
+ Make_Identifier (Loc,
+ Direct_Attribute_Definition_Name (Typ,
+ Name_Constructor)));
+ else
+ Constructor_Name :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Result_Id, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc,
+ Direct_Attribute_Definition_Name (Typ,
+ Name_Constructor)));
+ end if;
+
+ Constructor_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Parameter_Associations => Constructor_Params,
+ Name => Constructor_Name);
+
+ -- Clear Comes_From_Source so that the expansion of the
+ -- object declaration is not handled as a source-level
+ -- construct and generates a redundant initialization
+ -- call.
+
+ Set_Comes_From_Source (Parent (N), False);
+
+ Set_Has_Init_Expression (Parent (N), False);
+ Set_Expression (Parent (N), Empty);
+ Insert_After (Parent (N), Constructor_Call);
+
+ declare
+ Errors : constant Nat := Serious_Errors_Detected;
+
+ begin
+ Analyze (Constructor_Call);
+
+ -- If the analysis of the call reported errors (for
+ -- example, because of a missing argument in the
+ -- source code) then prevent Analyze_Declarations
+ -- from re-analyzing this call: Transform_Object_
+ -- Operation modifies the actuals in place, and a
+ -- second pass would produce spurious errors.
+
+ if Serious_Errors_Detected > Errors then
+ Set_Analyzed (Constructor_Call);
+ end if;
+ end;
+
+ -- Expand T'Make (...) into:
+
+ -- do
+ -- tmp : <Type>;
+ -- tmp.<Type>_constructor_Att (...)
+ -- in tmp end
+
+ else
+ Result_Id := Make_Temporary (Loc, 'D', N);
+ Mutate_Ekind (Result_Id, E_Variable);
+
+ Result_Decl :=
+ Make_Object_Declaration (Loc,
+ Defining_Identifier => Result_Id,
+ Object_Definition => New_Occurrence_Of (Typ, Loc));
+ Set_Suppress_Initialization (Result_Id);
+
+ Constructor_Name :=
+ Make_Selected_Component (Loc,
+ Prefix =>
+ New_Occurrence_Of (Result_Id, Loc),
+ Selector_Name =>
+ Make_Identifier (Loc,
+ Direct_Attribute_Definition_Name (Typ,
+ Name_Constructor)));
+
+ Constructor_Call :=
+ Make_Procedure_Call_Statement (Loc,
+ Parameter_Associations => Constructor_Params,
+ Name => Constructor_Name);
+
+ Rewrite (N,
+ Make_Expression_With_Actions (Loc,
+ Actions =>
+ New_List (Result_Decl, Constructor_Call),
+ Expression =>
+ New_Occurrence_Of (Result_Id, Loc)));
+
+ Analyze_And_Resolve (N, Typ);
+ end if;
end;
end if;
-
- Rewrite (N, Constructor_Rhs);
end;
- Analyze_And_Resolve (N, Typ);
-
--------------
-- Mantissa --
--------------
diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb
index 12cbd58a42b..d92ab21976d 100644
--- a/gcc/ada/exp_ch3.adb
+++ b/gcc/ada/exp_ch3.adb
@@ -1406,6 +1406,9 @@ package body Exp_Ch3 is
and then Comes_From_Source (N)
and then Needs_Construction (Typ)
then
+ -- If the parameterless constructor is not available, the
+ -- constructor call will cause reporting an error later.
+
return
Make_Attribute_Reference (Loc,
Prefix => New_Occurrence_Of (Typ, Loc),
@@ -1790,6 +1793,7 @@ package body Exp_Ch3 is
Body_Stmts, Parameters, Aspect_Specs : List_Id;
Spec_Node, Stmt : Node_Id;
Self, From : Entity_Id;
+
begin
-- Only build copy constructor for user-defined non-limited tagged
-- record types that needs construction without having declared a copy
@@ -1997,6 +2001,7 @@ package body Exp_Ch3 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
@@ -2039,6 +2044,8 @@ package body Exp_Ch3 is
Freeze_Extra_Formals (Constructor_Id);
+ -- Aspect Initialize enables default initialization
+
declare
Ignore : Node_Id;
Default_Initialize : constant Node_Id :=
diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb
index 1bad0f9a3c8..e8eaa7556b7 100644
--- a/gcc/ada/exp_ch4.adb
+++ b/gcc/ada/exp_ch4.adb
@@ -4562,13 +4562,14 @@ package body Exp_Ch4 is
Error_Msg_N ("?_a?use of an anonymous access type allocator", N);
end if;
- -- Here we set no initialization on types with constructors since we
- -- generate initialization for the separately.
+ -- Suppress default initialization on internally generated allocators
+ -- since they are initialized separately.
- if Needs_Construction (Directly_Designated_Type (PtrT))
+ if not Comes_From_Source (Parent (N))
+ and then Needs_Construction (Directly_Designated_Type (PtrT))
and then Nkind (Expression (N)) = N_Identifier
then
- Set_No_Initialization (N, False);
+ Set_No_Initialization (N);
end if;
-- RM E.2.2(17). We enforce that the expected type of an allocator
diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb
index 968a7db4914..79359f5f846 100644
--- a/gcc/ada/exp_ch6.adb
+++ b/gcc/ada/exp_ch6.adb
@@ -5924,353 +5924,361 @@ package body Exp_Ch6 is
procedure Prepend_Constructor_Procedure_Prologue
(Spec_Id : Entity_Id; Body_Id : Entity_Id; L : List_Id)
is
+ 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 First_Param_Type return Entity_Id is
- (Implementation_Base_Type (Etype (First_Formal (Spec_Id))));
+ 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.
- begin
- if not (Nkind (Specification (N)) = N_Procedure_Specification
- and then Is_Constructor (Spec_Id))
- then
- return; -- the usual case
- end if;
+ function Make_Init_Proc_Call
+ (Component : Entity_Id;
+ Component_Name : Node_Id) return Node_Id;
+ -- Build and return a call to the init proc for the type of the
+ -- component to initialize it.
- Push_Scope (Spec_Id);
+ 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.
- -- 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.
+ --------------------------------
+ -- From_Initialize_Expression --
+ --------------------------------
- -- 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 :=
+ function Init_From_Initialize_Expression
+ (Component : Entity_Id) return Node_Id
+ is
+ 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_Cursor : Node_Id := First_Initialize_Comp_Assoc;
+ Choice : Node_Id;
+ Others_Expression : Node_Id := Empty;
- Component : Entity_Id := First_Entity (First_Param_Type);
- 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.
+ -- ??? 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 (Component_Cursor) loop
+ Choice := First (Choices (Component_Cursor));
- 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.
+ while Present (Choice) loop
+ -- The others expression is used in case there is no
+ -- explicit component association for the given one.
- 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.
+ if Nkind (Choice) = N_Others_Choice
+ and then Comes_From_Source (Choice)
+ then
+ Others_Expression := Expression (Component_Cursor);
- 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.
-
- --------------------------------
- -- From_Initialize_Expression --
- --------------------------------
-
- function Init_From_Initialize_Expression (Component : Entity_Id)
- return Node_Id
- is
- 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 (Component_Cursor) loop
- Choice := First (Choices (Component_Cursor));
-
- while Present (Choice) loop
- -- 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 (Component_Cursor);
- end if;
- Next (Choice);
- end loop;
-
- Next (Component_Cursor);
+ elsif Nkind (Choice) = N_Identifier
+ and then Chars (Choice) = Chars (Component)
+ then
+ return Expression (Component_Cursor);
+ end if;
+ Next (Choice);
end loop;
- 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;
-
- -- 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_From_Default_Or_Constructor;
-
- -------------------------
- -- 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
- -- 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.
-
- 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;
-
- return Make_Assignment_Statement (Loc,
- Name =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (First_Formal (Spec_Id), Loc),
- Attribute_Name => Name_Super),
- Expression =>
- Make_Attribute_Reference (Loc,
- Prefix =>
- New_Occurrence_Of (Parent_Type, Loc),
- Attribute_Name => Name_Make,
- Expressions => Actual_Parameters));
- end Make_Parent_Constructor_Call;
-
- begin
- while Present (Component) loop
-
- -- Skip if not a component, this may happen when initialization
- -- expressions contain strings.
-
- if Ekind (Component) /= E_Component then
- goto Next_Component;
- 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));
-
- elsif Chars (Component) = Name_uParent
- and then Needs_Construction (Etype (Component))
- then
- Append_To (Parent_List,
- Make_Parent_Constructor_Call
- (Parent_Type => Etype (Component)));
-
- else
- declare
- 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,
- 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_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 (Comp_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_Component>>
- Next_Entity (Component);
+ Next (Component_Cursor);
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.
+ return Others_Expression;
+ end Init_From_Initialize_Expression;
- 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;
+ --------------------------------------
+ -- Init_From_Default_Or_Constructor --
+ --------------------------------------
- Pop_Scope;
+ 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;
+
+ -- 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_From_Default_Or_Constructor;
+
+ -------------------------
+ -- 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
+ pragma Assert (Present (Init_Proc));
+
+ 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;
+ Lhs : Node_Id;
+ 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
+ -- 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.
+
+ 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;
+
+ Lhs :=
+ Make_Attribute_Reference (Loc,
+ Prefix =>
+ New_Occurrence_Of (First_Formal (Spec_Id), Loc),
+ Attribute_Name => Name_Super);
+ Set_Assignment_OK (Lhs);
+
+ return Make_Assignment_Statement (Loc,
+ Name => Lhs,
+ Expression =>
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Parent_Type, Loc),
+ Attribute_Name => Name_Make,
+ Expressions => Actual_Parameters));
+ end Make_Parent_Constructor_Call;
+
+ -- Local variables
+
+ First_Param_Type : constant Entity_Id :=
+ Implementation_Base_Type
+ (Etype (First_Formal (Spec_Id)));
+ 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;
+ -- Tag_List contains the initialization for the tag;
+ -- Parent_List contains the parent constructor call.
+
+ -- Start of processing for Prepend_Constructor_Procedure_Prologue
+
+ begin
+ pragma Assert (Is_Constructor (Spec_Id));
+
+ Install_Formals (Spec_Id);
+ Push_Scope (Spec_Id);
+
+ -- 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.
+
+ -- 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.
+
+ Component := First_Entity (First_Param_Type);
+ while Present (Component) loop
+
+ -- Skip if not a component, this may happen when initialization
+ -- expressions contain strings.
+
+ if Ekind (Component) /= E_Component then
+ goto Next_Component;
+ 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));
+
+ elsif Chars (Component) = Name_uParent
+ and then Needs_Construction (Etype (Component))
+ then
+ Append_To (Parent_List,
+ Make_Parent_Constructor_Call
+ (Parent_Type => Etype (Component)));
+
+ else
+ declare
+ 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,
+ 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_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
+
+ if not Has_Discriminants (Etype (Component)) then
+ Append_To (Comp_List,
+ Make_Init_Proc_Call (
+ Component => Component,
+ Component_Name => Make_Component_Name));
+ else
+ Append_List_To (Comp_List,
+ Build_Initialization_Call
+ (N => Parent (Component),
+ Id_Ref => Make_Component_Name,
+ Typ => Etype (Component),
+ In_Init_Proc => True,
+ Enclos_Type => First_Param_Type));
+ end if;
+
+ else
+ pragma Assert (not Is_Tagged_Type (Etype (Component)));
+ end if;
+ end;
+ end if;
+
+ <<Next_Component>>
+ 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.
+
+ 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_Scope;
end Prepend_Constructor_Procedure_Prologue;
-- Local variables
@@ -6508,8 +6516,12 @@ package body Exp_Ch6 is
-- 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);
+ if Nkind (Specification (N)) = N_Procedure_Specification
+ and then Is_Constructor (Spec_Id)
+ then
+ Prepend_Constructor_Procedure_Prologue
+ (Spec_Id => Spec_Id, Body_Id => Body_Id, L => L);
+ end if;
-- Set to encode entity names in package body before gigi is called
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 5c786e7fb4c..e9c6ef6b7d7 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -6059,22 +6059,19 @@ package body Sem_Ch13 is
elsif Asp_Nam = Name_Post then
Misplaced_Aspect_Error (Asp, Name_Refined_Post);
+ -- Likely a misspelling of Initialize aspect (singular) that can
+ -- be used in stubs.
+
+ elsif Asp_Nam = Name_Initializes then
+ Error_Msg_Name_1 := Name_Initialize;
+ Error_Msg_N ("\possible misspelling of%", Asp);
+
-- Otherwise a language-defined aspect is misplaced
else
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);
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index e07d24c1565..52eaf0f3399 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -21124,8 +21124,12 @@ package body Sem_Ch3 is
-- attribute will be changed to a call, but the attribute by itself
-- can occur with -gnatc.
+ -- Similarly, T'Make (GNAT-specific constructor attribute) is also
+ -- allowed because it is semantically equivalent to a function call.
+
when N_Attribute_Reference =>
- return Attribute_Name (Original_Node (Exp)) = Name_Input;
+ return Attribute_Name (Original_Node (Exp)) in Name_Input
+ | Name_Make;
-- "return raise ..." is OK
diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index fd12a557108..95cd7c0f35e 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -5278,11 +5278,13 @@ package body Sem_Ch6 is
Att_N : constant Node_Id := Original_Node (N);
Prefix_E : constant Entity_Id :=
- Get_Name_Entity_Id (Chars (Prefix (Defining_Unit_Name (Att_N))));
+ Get_Full_View
+ (Current_Entity (Prefix (Defining_Unit_Name (Att_N))));
Att_Name : constant Name_Id :=
Attribute_Name (Defining_Unit_Name (Att_N));
- -- Start of processing for Analyze_Direct_Attribute_Definition
+ -- Start of processing for Analyze_Direct_Attribute_Definition
+
begin
pragma Assert (N /= Att_N);
diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 028e170021e..9ea8edc5259 100644
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -4808,9 +4808,16 @@ package body Sem_Res is
-- component may initialize a nested component of a constant
-- designated object. In this context the object is variable.
+ -- Similarly, a constructor may be invoked to initialize a
+ -- constant variable, and this is allowed.
+
if not Is_OK_Variable_For_Out_Formal (A)
- and then not Is_Init_Proc (Nam)
- and then not Is_Expanded_Constructor_Call (N)
+ and then not
+ (A = First_Actual (N)
+ and then
+ (Is_Init_Proc (Nam)
+ or else Is_Constructor (Nam)
+ or else Is_Expanded_Constructor_Call (N)))
then
Error_Msg_NE ("actual for& must be a variable", A, F);
--
2.53.0
