https://gcc.gnu.org/g:56d64fcb9ea143785b4b834f1b501a4387188e1b
commit r17-1287-g56d64fcb9ea143785b4b834f1b501a4387188e1b Author: Javier Miranda <[email protected]> Date: Thu Apr 30 18:30:42 2026 +0000 ada: Allow limited type initialization via constructors 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. Diff: --- 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 | 634 ++++++++++++++++++++++++++------------------------- 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, 565 insertions(+), 412 deletions(-) diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 2c427b7515ed..cf11a0a6c1ca 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 b46adc18abcc..aa2810b5b04e 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 2a3f7e3c6bc2..039c342d05e2 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 b299dacebfc6..aa5d9696804e 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; + Constructor_Name : Node_Id; + Result_Decl : Node_Id; + Result_Id : Entity_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_Rhs := - Make_Expression_With_Actions (Loc, - Actions => New_List (Result_Decl, Constructor_Call), - Expression => New_Occurrence_Of (Result_Id, Loc)); + -- 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 12cbd58a42bd..d92ab21976d9 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 1bad0f9a3c87..e8eaa7556b7c 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 968a7db49143..79359f5f846c 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 First_Param_Type return Entity_Id is - (Implementation_Base_Type (Etype (First_Formal (Spec_Id)))); - - begin - if not (Nkind (Specification (N)) = N_Procedure_Specification - and then Is_Constructor (Spec_Id)) - then - return; -- the usual case - end if; - - Push_Scope (Spec_Id); - - -- 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 := + 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) return Node_Id; + -- Build and return a call to the init proc for the type of the + -- component to initialize it. + + 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 + 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; + + -- ??? 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)); - 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. - - 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) - 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. - 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); - 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; - 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); + end loop; - Next (Component_Cursor); - end loop; + return Others_Expression; + end Init_From_Initialize_Expression; - return Others_Expression; - end Init_From_Initialize_Expression; + -------------------------------------- + -- Init_From_Default_Or_Constructor -- + -------------------------------------- - -------------------------------------- - -- 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; - 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. - -- 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; - 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; - return Empty; - end Init_From_Default_Or_Constructor; + ------------------------- + -- Make_Init_Proc_Call -- + ------------------------- - ------------------------- - -- 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)); - 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; + 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. + 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; - if No (Super_Expr) then - Actual_Parameters := No_List; + begin + -- Super without expression is a call to the parent + -- parameterless constructor. - elsif Nkind (Super_Expr) /= N_Aggregate then - Expr := New_Copy_Tree (Super_Expr); - Set_Paren_Count (Expr, 0); - Actual_Parameters := New_List (Expr); + if No (Super_Expr) then + Actual_Parameters := No_List; - 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; + elsif Nkind (Super_Expr) /= N_Aggregate then + Expr := New_Copy_Tree (Super_Expr); + Set_Paren_Count (Expr, 0); + Actual_Parameters := New_List (Expr); - 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; + 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; - begin - while Present (Component) loop + Lhs := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (First_Formal (Spec_Id), Loc), + Attribute_Name => Name_Super); + Set_Assignment_OK (Lhs); - -- Skip if not a component, this may happen when initialization - -- expressions contain strings. + 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; - if Ekind (Component) /= E_Component then - goto Next_Component; - end if; + -- Local variables - 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)); + First_Param_Type : constant Entity_Id := + Implementation_Base_Type + (Etype (First_Formal (Spec_Id))); + Component : Entity_Id; - elsif Chars (Component) = Name_uParent - and then Needs_Construction (Etype (Component)) - then - Append_To (Parent_List, - Make_Parent_Constructor_Call - (Parent_Type => Etype (Component))); + 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. - 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. + -- Start of processing for Prepend_Constructor_Procedure_Prologue - 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 + 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)); + Make_Init_Proc_Call ( + Component => Component, + Component_Name => Make_Component_Name)); else - pragma Assert (not Is_Tagged_Type (Etype (Component))); + 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; - end; - end if; - <<Next_Component>> - Next_Entity (Component); - end loop; + else + pragma Assert (not Is_Tagged_Type (Etype (Component))); + end if; + end; + end if; - -- 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. + <<Next_Component>> + Next_Entity (Component); + end loop; - 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; + -- 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. - Pop_Scope; + 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 5c786e7fb4c2..e9c6ef6b7d7b 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 e07d24c15651..52eaf0f3399f 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 fd12a5571087..95cd7c0f35e1 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 028e170021e4..9ea8edc52597 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);
