https://gcc.gnu.org/g:efc879731b563a501421c34674665582be9cf9c5
commit r16-6614-gefc879731b563a501421c34674665582be9cf9c5 Author: Denis Mazzucato <[email protected]> Date: Wed Nov 19 14:13:35 2025 +0100 ada: Implement copy constructors This patch implements the copy constructor as a particular type of constructor that copies its second parameter "From" into the first implicit "Self" parameter. The copy constructor is called via the 'Make attribute and is always available for tagged types. Internally, when missing an implicit copy constructor with default behavior is generated. Sometimes, when its behavior wouldn't differ from the default byte-wise copy, no entity is actually generated. In this case, whenever the copy constructor is called via the 'Make attribute, the call is rewritten simply as its parameter "From". gcc/ada/ChangeLog: * exp_attr.adb (Expand_N_Attribute_Reference): Do not expand copy constructor calls when unnecessary. * exp_ch3.adb (Build_Implicit_Copy_Constructor): If necessary, build the implicit copy constructor as part of the initialization procedures of its type. (Expand_N_Object_Declaration): Add implicit 'Make attribute calls for objects that may need construction. * exp_ch6.adb (Make_Parent_Constructor_Call): Constructor's procedure calls should be only generated from expansion of the 'Make attribute as there is hidden logic to handle copy constructors. * sem_attr.adb (Analyze_Attribute): Emit a specific error message if a non-copy constructor is called but no constructor is defined. * sem_ch13.adb (Analyze_Aspect_Specifications): The Ekind of the implicitly generated copy constructor is not a subprogram body. * sem_ch4.adb (Extended_Primitive_Ops): Extend the operation list that can be called via prefix notation to include constructors. * sem_ch6.adb (Check_For_Primitive_Subprogram): Skip constructors for primitive analysis. * sem_util.adb (Has_Matching_Constructor): Generic function to check for the existence of a constructor matching a given condition. (Has_Copy_Constructor): Check whether a type has an implicit or explicit copy constructor. (Has_Default_Constructor): Use Has_Matching_Constructor. (Is_Copy_Constructor): Check whether a subprogram is a copy constructor. (Is_Copy_Constructor_Call): Check whether an attribute call is call to a copy constructor. * sem_util.ads: Add specs for copy constructor utility functions. * snames.ads-tmpl (Snames): Add names Self and From. Diff: --- gcc/ada/exp_attr.adb | 63 +++++++----- gcc/ada/exp_ch3.adb | 252 ++++++++++++++++++++++++++++++++++++++++++++++-- gcc/ada/exp_ch6.adb | 41 +++----- gcc/ada/sem_attr.adb | 14 +-- gcc/ada/sem_ch13.adb | 4 +- gcc/ada/sem_ch4.adb | 28 +++++- gcc/ada/sem_ch6.adb | 7 +- gcc/ada/sem_util.adb | 166 +++++++++++++++++++++++++------ gcc/ada/sem_util.ads | 32 +++++- gcc/ada/snames.ads-tmpl | 2 + 10 files changed, 511 insertions(+), 98 deletions(-) diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 48138e998834..8816ec6ea8a2 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -5277,8 +5277,7 @@ package body Exp_Attr is when Attribute_Make => declare Constructor_Params : List_Id := New_Copy_List (Expressions (N)); - Constructor_Call : Node_Id; - Constructor_EWA : Node_Id; + Constructor_Rhs : Node_Id; Result_Decl : Node_Id; Result_Id : constant Entity_Id := Make_Temporary (Loc, 'D', N); @@ -5299,31 +5298,49 @@ package body Exp_Attr is Mutate_Ekind (Result_Id, E_Variable); Set_Suppress_Initialization (Result_Id); - -- Build a prefixed-notation call + -- 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 + -- case, we rewrite the call simply as its unique actual. - declare - Proc_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))); - begin - Set_Is_Prefixed_Call (Proc_Name); - - Constructor_Call := Make_Procedure_Call_Statement (Loc, - Parameter_Associations => Constructor_Params, - Name => Proc_Name); - end; + 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))); + else + Constructor_Rhs := Relocate_Node (First (Exprs)); + end if; - Set_Is_Expanded_Constructor_Call (Constructor_Call, True); + -- Otherwise build a prefixed-notation call - Constructor_EWA := - Make_Expression_With_Actions (Loc, - Actions => New_List (Result_Decl, Constructor_Call), - Expression => New_Occurrence_Of (Result_Id, Loc)); + 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_Rhs := + Make_Expression_With_Actions (Loc, + Actions => New_List (Result_Decl, Constructor_Call), + Expression => New_Occurrence_Of (Result_Id, Loc)); + end; + end if; - Rewrite (N, Constructor_EWA); + Rewrite (N, Constructor_Rhs); end; Analyze_And_Resolve (N, Typ); diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 1b53199cb4e2..78e4f44c1919 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -96,6 +96,10 @@ package body Exp_Ch3 is -- used for attachment of any actions required in its construction. -- It also supplies the source location used for the procedure. + procedure Build_Implicit_Copy_Constructor (N : Node_Id; Typ : Entity_Id); + -- Build default copy constructor. N is the type declaration node, and Typ + -- is the corresponding entity for the record type. + function Build_Discriminant_Formals (Rec_Id : Entity_Id; Use_Dl : Boolean) return List_Id; @@ -1752,6 +1756,217 @@ package body Exp_Ch3 is end if; end Build_Or_Copy_Discr_Checking_Funcs; + ------------------------------------- + -- Build_Implicit_Copy_Constructor -- + ------------------------------------- + + procedure Build_Implicit_Copy_Constructor (N : Node_Id; Typ : Entity_Id) is + Loc : constant Source_Ptr := Sloc (Typ); + Copy_Id : Entity_Id; + + Comp_List, Comp_Decl : Node_Id; + Comp_Id, Comp_Typ : Entity_Id; + + 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 + -- constructor already, or without having it explicitly removed. This + -- implicit copy needs to call first the parent's copy constructor (if + -- derived), second to copy field-by-field the components, and third to + -- call their respective copy constructors if necessary. + + if not Comes_From_Source (N) + or else Is_Limited_Type (Typ) + or else not Is_Tagged_Type (Typ) + or else not Needs_Construction (Typ) + or else Has_Copy_Constructor (Typ, Allow_Removed => True) + then + return; + end if; + + if Is_Derived_Type (Typ) then + Comp_List := + Component_List (Record_Extension_Part (Type_Definition (N))); + else + Comp_List := Component_List (Type_Definition (N)); + end if; + + -- Here, there is still a possibility that an implicit copy constructor + -- is actually not needed. + + declare + Found : Boolean := False; + begin + if Present (Comp_List) then + Comp_Decl := First_Non_Pragma (Component_Items (Comp_List)); + while not Found and then Present (Comp_Decl) loop + Comp_Id := Defining_Identifier (Comp_Decl); + Comp_Typ := Etype (Comp_Id); + if Has_Copy_Constructor (Comp_Typ) then + Found := True; + end if; + Next_Non_Pragma (Comp_Decl); + end loop; + end if; + + -- If Found is false, then there is no component in the current type + -- with a copy constructor. If also the type is either not derived or + -- its parent has no copy constructor, then there is no need for a + -- copy constructor for the current type as its behavior would be + -- identical to the byte-wise copy provided by assignment. + + if not Found + and then (if Is_Derived_Type (Typ) + then not Has_Copy_Constructor (Parent_Subtype (Typ))) + then + return; + end if; + end; + + Copy_Id := + Make_Defining_Identifier (Loc, + Direct_Attribute_Definition_Name (Typ, Name_Constructor)); + Mutate_Ekind (Copy_Id, E_Procedure); + + if not Debug_Generated_Code then + Set_Debug_Info_Off (Copy_Id); + end if; + + -- The copy constructor has the following profile: + -- procedure T'Constructor (Self : in out T; From : T); + + Self := Make_Defining_Identifier (Loc, Name_Self); + From := Make_Defining_Identifier (Loc, Name_From); + + Parameters := New_List ( + Make_Parameter_Specification (Loc, + Defining_Identifier => Self, + In_Present => True, + Out_Present => True, + Parameter_Type => New_Occurrence_Of (Typ, Loc)), + Make_Parameter_Specification (Loc, + Defining_Identifier => From, + In_Present => True, + Parameter_Type => New_Occurrence_Of (Typ, Loc))); + + -- The first thing to do in the implicit copy constructor is to copy + -- components field-by-field, the parent copy constructor call is + -- prepended later via the 'Super aspect. + + Body_Stmts := New_List; + if Present (Comp_List) then + Comp_Decl := First_Non_Pragma (Component_Items (Comp_List)); + while Present (Comp_Decl) loop + Comp_Id := Defining_Identifier (Comp_Decl); + Comp_Typ := Etype (Comp_Id); + + if Chars (Comp_Id) not in Name_uParent | Name_uTag then + Stmt := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Self, Loc), + Selector_Name => New_Occurrence_Of (Comp_Id, Loc)), + Expression => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (From, Loc), + Selector_Name => New_Occurrence_Of (Comp_Id, Loc))); + Set_Assignment_OK (Name (Stmt)); + Set_No_Ctrl_Actions (Stmt); + Append_To (Body_Stmts, Stmt); + end if; + + Next_Non_Pragma (Comp_Decl); + end loop; + + -- Then, call the copy constructor for each component that needs + -- construction and has a copy constructor. + + Comp_Decl := First_Non_Pragma (Component_Items (Comp_List)); + while Present (Comp_Decl) loop + Comp_Id := Defining_Identifier (Comp_Decl); + Comp_Typ := Etype (Comp_Id); + + -- For each component that has a copy constructor, generate: + -- Self.Comp_Id := Comp_Typ'Make (From.Comp_Id); + + if Chars (Comp_Id) /= Name_uParent + and then Needs_Construction (Comp_Typ) + and then Has_Copy_Constructor (Comp_Typ) + then + Stmt := + Make_Assignment_Statement (Loc, + Name => + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (Self, Loc), + Selector_Name => New_Occurrence_Of (Comp_Id, Loc)), + Expression => + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Comp_Typ, Loc), + Attribute_Name => Name_Make, + Expressions => New_List ( + Make_Selected_Component (Loc, + Prefix => New_Occurrence_Of (From, Loc), + Selector_Name => + New_Occurrence_Of (Comp_Id, Loc))))); + Set_Assignment_OK (Name (Stmt)); + Append_To (Body_Stmts, Stmt); + end if; + + -- Components that do not need construction or lack a copy + -- constructor are simply skipped since the expansion of a + -- constructor also takes care of default copies/initializations. + + Next_Non_Pragma (Comp_Decl); + end loop; + end if; + + -- Prepend the call to the parent's copy constructor if derived + + if Is_Derived_Type (Typ) + and then Has_Copy_Constructor (Parent_Subtype (Typ)) + then + Aspect_Specs := New_List + (Make_Aspect_Specification (Loc, + Identifier => Make_Identifier (Loc, Name_Super), + Expression => + Make_Aggregate (Loc, + Expressions => New_List ( + Make_Type_Conversion (Loc, + Subtype_Mark => + New_Occurrence_Of (Parent_Subtype (Typ), Loc), + Expression => New_Occurrence_Of (From, Loc))), + Is_Parenthesis_Aggregate => True, + Is_Homogeneous_Aggregate => True))); + else + Aspect_Specs := No_List; + end if; + + Spec_Node := New_Node (N_Procedure_Specification, Loc); + Set_Defining_Unit_Name (Spec_Node, Copy_Id); + Set_Parameter_Specifications (Spec_Node, Parameters); + Freeze_Extra_Formals (Copy_Id); + + declare + Ignore : Node_Id; + begin + Ignore := + Make_Subprogram_Body (Loc, + Specification => Spec_Node, + Aspect_Specifications => Aspect_Specs, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Body_Stmts)); + end; + + Set_Is_Public (Copy_Id, Is_Public (Typ)); + Set_Is_Internal (Copy_Id); + Set_Is_Constructor (Copy_Id); + Set_Init_Proc (Typ, Copy_Id); + end Build_Implicit_Copy_Constructor; + -------------------------------- -- Build_Discriminant_Formals -- -------------------------------- @@ -6518,6 +6733,7 @@ package body Exp_Ch3 is and then (Tagged_Type_Expansion or else not Is_Interface (Typ)) then Build_Record_Init_Proc (Typ_Decl, Typ); + Build_Implicit_Copy_Constructor (Typ_Decl, Typ); end if; -- Create the body of TSS primitive Finalize_Address. This must be done @@ -7615,17 +7831,39 @@ package body Exp_Ch3 is return; end if; - -- Expand objects with default constructors to have the 'Make - -- attribute. + -- Expand objects to use constructors if needed if Comes_From_Source (N) - and then No (Expr) and then Needs_Construction (Typ) - and then Has_Default_Constructor (Typ) + + -- Don't expand copy constructor for objects initialized with aggregates + + and then (if Present (Expr) + then Nkind (Expr) not in N_Aggregate + | N_Delta_Aggregate + | N_Extension_Aggregate) + + -- Don't expand copy constructor if a constructor was explicitly called + + and then (if Present (Expr) + then (Nkind (Original_Node (Expr)) /= N_Attribute_Reference + or else Attribute_Name (Original_Node (Expr)) + /= Name_Make)) then - Expr := Make_Attribute_Reference (Loc, - Attribute_Name => Name_Make, - Prefix => Object_Definition (N)); + if No (Expr) then + Expr := + Make_Attribute_Reference + (Loc, + Attribute_Name => Name_Make, + Prefix => New_Occurrence_Of (Typ, Loc)); + else + Expr := + Make_Attribute_Reference + (Loc, + Attribute_Name => Name_Make, + Prefix => New_Occurrence_Of (Typ, Loc), + Expressions => New_List (Expr)); + end if; Set_Expression (N, Expr); Analyze_And_Resolve (Expr); end if; diff --git a/gcc/ada/exp_ch6.adb b/gcc/ada/exp_ch6.adb index 981cb2c86840..e4c110b44c91 100644 --- a/gcc/ada/exp_ch6.adb +++ b/gcc/ada/exp_ch6.adb @@ -6493,26 +6493,18 @@ package body Exp_Ch6 is 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, - Direct_Attribute_Definition_Name - (Parent_Type, Name_Constructor))); - begin - Set_Is_Prefixed_Call (Proc_Name); - - return Make_Procedure_Call_Statement (Loc, - Name => Proc_Name, - Parameter_Associations => Actual_Parameters); - end; + 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 @@ -6522,12 +6514,9 @@ package body Exp_Ch6 is 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). + elsif Chars (Component) = Name_uParent + and then Needs_Construction (Etype (Component)) + then Append_To (Init_List, Make_Parent_Constructor_Call (Parent_Type => Etype (Component))); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 3ee40c69d94f..af4994419eb4 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -5201,12 +5201,8 @@ package body Sem_Attr is Check_Type; Set_Etype (N, Etype (P)); - if not Needs_Construction (Entity (P)) then - Error_Msg_NE ("no available constructor for&", N, Entity (P)); - end if; - - if Present (Expressions (N)) then - Expr := First (Expressions (N)); + if Present (Exprs) then + Expr := First (Exprs); while Present (Expr) loop if Nkind (Expr) = N_Parameter_Association then Analyze (Explicit_Actual_Parameter (Expr)); @@ -5217,6 +5213,12 @@ package body Sem_Attr is Next (Expr); end loop; + if not Is_Copy_Constructor_Call (N) + and then not Needs_Construction (Entity (P)) + then + Error_Msg_NE ("no available constructor for&", N, Entity (P)); + end if; + elsif not Has_Default_Constructor (Entity (P)) then Error_Msg_NE ("no default constructor for&", N, Entity (P)); end if; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index 8624c1d64521..0aad2f92ca00 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -5281,9 +5281,7 @@ package body Sem_Ch13 is goto Continue; end if; - if Ekind (E) /= E_Subprogram_Body - or else Nkind (Parent (E)) /= N_Procedure_Specification - then + if Nkind (N) /= N_Subprogram_Body then Error_Msg_N ("Super must apply to a constructor body", N); end if; diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 1a9e37ce92da..ad560ee39792 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -10523,8 +10523,8 @@ package body Sem_Ch4 is -- We retrieve the candidate operations from the generic declaration. function Extended_Primitive_Ops (T : Entity_Id) return Elist_Id; - -- Prefix notation can also be used on operations that are not - -- primitives of the type, but are declared in the same immediate + -- Prefix notation can also be used on either constructors, which are + -- never primitives; or operations declared in the same immediate -- declarative part, which can only mean the corresponding package -- body (see RM 4.1.3 (9.2/3)). If we are in that body we extend the -- list of primitives with body operations with the same name that @@ -10656,7 +10656,30 @@ package body Sem_Ch4 is function Extended_Primitive_Ops (T : Entity_Id) return Elist_Id is Type_Scope : constant Entity_Id := Scope (T); Op_List : Elist_Id := Primitive_Operations (T); + Op_Found : Boolean := False; begin + if Needs_Construction (T) then + -- to include all constructors iterate over T's entities + + declare + Cursor : Entity_Id := Next_Entity (T); + begin + while Present (Cursor) loop + if Is_Constructor (Cursor) then + if not Op_Found then + -- Copy list of primitives so it is not affected + -- for other uses. + + Op_List := New_Copy_Elist (Op_List); + Op_Found := True; + end if; + Append_Elmt (Cursor, Op_List); + end if; + Next_Entity (Cursor); + end loop; + end; + end if; + if Is_Package_Or_Generic_Package (Type_Scope) and then ((In_Package_Body (Type_Scope) and then In_Open_Scopes (Type_Scope)) or else In_Instance_Body) @@ -10671,7 +10694,6 @@ package body Sem_Ch4 is declare Body_Decls : constant List_Id := Declarations (Unit_Declaration_Node (The_Body)); - Op_Found : Boolean := False; Op : Entity_Id := Current_Entity (Subprog); begin while Present (Op) loop diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index d48735a3bd77..33f5e1c67ac8 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -11856,7 +11856,12 @@ package body Sem_Ch6 is begin Is_Primitive := False; - if not Comes_From_Source (S) then + -- Constructors are never primitive operations + + if Is_Constructor (S) then + null; + + elsif not Comes_From_Source (S) then if Present (Derived_Type) then -- Add an inherited primitive for an untagged derived type to diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 286b4612eb3b..42ab46dd32a2 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -11859,29 +11859,16 @@ package body Sem_Util is -- Has_Default_Constructor -- ----------------------------- - function Has_Default_Constructor (Typ : Entity_Id) return Boolean is - Cursor : Entity_Id; - begin - pragma Assert (Is_Type (Typ)); - if not Needs_Construction (Typ) then - return False; - end if; - - -- Iterate through all homonyms to find the default constructor - - Cursor := Get_Name_Entity_Id - (Direct_Attribute_Definition_Name (Typ, Name_Constructor)); - while Present (Cursor) loop - if Is_Constructor (Cursor) - and then No (Next_Formal (First_Formal (Cursor))) - then - return True; - end if; - - Cursor := Homonym (Cursor); - end loop; + function Has_Default_Constructor + (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean + is + function No_Next_Formal (N : Entity_Id) return Boolean + is (No (Next_Formal (First_Formal (N)))); - return False; + function Internal_Has_Default_Constructor + is new Has_Matching_Constructor (No_Next_Formal); + begin + return Internal_Has_Default_Constructor (Typ, Allow_Removed); end Has_Default_Constructor; ------------------- @@ -12337,6 +12324,19 @@ package body Sem_Util is end if; end Has_Enabled_Property; + -------------------------- + -- Has_Copy_Constructor -- + -------------------------- + + function Has_Copy_Constructor + (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean + is + function Internal_Has_Copy_Constructor + is new Has_Matching_Constructor (Is_Copy_Constructor); + begin + return Internal_Has_Copy_Constructor (Typ, Allow_Removed); + end Has_Copy_Constructor; + ------------------------------------- -- Has_Full_Default_Initialization -- ------------------------------------- @@ -12635,6 +12635,40 @@ package body Sem_Util is Present (Get_Pragma (Id, Pragma_Max_Entry_Queue_Length))); end Has_Max_Queue_Length; + ------------------------------ + -- Has_Matching_Constructor -- + ------------------------------ + + function Has_Matching_Constructor + (Typ : Entity_Id; Allow_Removed : Boolean) return Boolean + is + Cursor : Entity_Id; + begin + pragma Assert (Is_Type (Typ)); + if not Needs_Construction (Typ) then + return False; + end if; + + -- Iterate through all constructors to find at least one constructor + -- that matches the given condition. + + Cursor := + Get_Name_Entity_Id + (Direct_Attribute_Definition_Name (Typ, Name_Constructor)); + while Present (Cursor) loop + if (if not Allow_Removed then not Is_Abstract_Subprogram (Cursor)) + and then Is_Constructor (Cursor) + and then Condition (Cursor) + then + return True; + end if; + + Cursor := Homonym (Cursor); + end loop; + + return False; + end Has_Matching_Constructor; + --------------------------------- -- Has_No_Obvious_Side_Effects -- --------------------------------- @@ -12763,6 +12797,80 @@ package body Sem_Util is and then not Is_Record_Aggregate; end Is_Container_Aggregate; + ------------------------- + -- Is_Copy_Constructor -- + ------------------------- + + function Is_Copy_Constructor (Spec_Id : Entity_Id) return Boolean is + begin + if Is_Constructor (Spec_Id) + and then Present (Next_Formal (First_Formal (Spec_Id))) + and then Etype (Next_Formal (First_Formal (Spec_Id))) + = Etype (First_Formal (Spec_Id)) + and then Ekind (Next_Formal (First_Formal (Spec_Id))) + = E_In_Parameter + then + -- More formals with default values are allowed afterwards + + declare + All_Defaults : Boolean := True; + Formal : Entity_Id := + Next_Formal (Next_Formal (First_Formal (Spec_Id))); + begin + while Present (Formal) loop + if No (Default_Value (Formal)) then + All_Defaults := False; + exit; + end if; + Next_Formal (Formal); + end loop; + + if All_Defaults then + return True; + end if; + end; + end if; + + return False; + end Is_Copy_Constructor; + + ------------------------------ + -- Is_Copy_Constructor_Call -- + ------------------------------ + + function Is_Copy_Constructor_Call (N : Node_Id) return Boolean is + begin + if Nkind (N) = N_Attribute_Reference + and then Is_Type (Entity (Prefix (N))) + and then Get_Attribute_Id (Attribute_Name (N)) = Attribute_Make + and then Present (Expressions (N)) + and then Present (First (Expressions (N))) + and then No (Next (First (Expressions (N)))) + then + -- If the actual is a parameter association, the selector name must + -- be "From" and its type must be an ancestor of the underlying one. + + if Nkind (First (Expressions (N))) = N_Parameter_Association then + return Chars (Selector_Name (First (Expressions (N)))) = Name_From + and then Is_Ancestor + (Etype (Entity (Prefix (N))), + Etype (Explicit_Actual_Parameter + (First (Expressions (N))))); + + -- The actual must be an ancestor of the underlying type to be used + -- in a copy constructor call. + + else + return Is_Ancestor + (Etype (Entity (Prefix (N))), + Etype (First (Expressions (N)))); + + end if; + else + return False; + end if; + end Is_Copy_Constructor_Call; + ----------------------------- -- Is_Extended_Access_Type -- ----------------------------- @@ -21565,16 +21673,18 @@ package body Sem_Util is function Is_Suitable_Primitive (Subp_Id : Entity_Id) return Boolean is begin - -- The Default_Initial_Condition and invariant procedures must not be - -- treated as primitive operations even when they apply to a tagged - -- type. These routines must not act as targets of dispatching calls - -- because they already utilize class-wide-precondition semantics to - -- handle inheritance and overriding. + -- The Default_Initial_Condition, invariant, and constructor procedures + -- must not be treated as primitive operations even when they apply to a + -- tagged type. These routines must not act as targets of dispatching + -- calls because they already utilize class-wide-precondition semantics + -- to handle inheritance and overriding. if Ekind (Subp_Id) = E_Procedure and then (Is_DIC_Procedure (Subp_Id) or else - Is_Invariant_Procedure (Subp_Id)) + Is_Invariant_Procedure (Subp_Id) + or else + Is_Constructor (Subp_Id)) then return False; end if; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 13b9163f4591..15e6ee1ce70e 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -1407,8 +1407,11 @@ package Sem_Util is function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; -- Simple predicate to test for defaulted discriminants - function Has_Default_Constructor (Typ : Entity_Id) return Boolean; + function Has_Default_Constructor + (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean; -- Determine whether Typ has a constructor with only one formal parameter. + -- If Allow_Removed is true, then also abstract constructors are considered + -- valid during the search. function Has_Denormals (E : Entity_Id) return Boolean; -- Determines if the floating-point type E supports denormal numbers. @@ -1425,6 +1428,13 @@ package Sem_Util is -- parameter for reading or returns an effectively volatile value for -- reading. + function Has_Copy_Constructor + (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean; + -- Return True if a copy constructor has been explicitly declared by the + -- user, or the implicit copy constructor has been generated by the + -- compiler. If Allow_Removed is true, then also abstract constructors are + -- considered valid during the search. + function Has_Full_Default_Initialization (Typ : Entity_Id) return Boolean; -- Determine whether type Typ defines "full default initialization" as -- specified by SPARK RM 3.1. To qualify as such, the type must be @@ -1472,6 +1482,15 @@ package Sem_Util is -- Determine whether Id is subject to pragma Max_Queue_Length. It is -- assumed that Id denotes an entry. + generic + with function Condition (E : Entity_Id) return Boolean; + function Has_Matching_Constructor + (Typ : Entity_Id; Allow_Removed : Boolean) return Boolean; + -- Determine whether Typ has a constructor whose profile matches the + -- condition specified by the generic Condition function. If + -- Allow_Removed is True, constructors that have been removed by marking + -- them abstract are considered as well in the search. + function Has_No_Obvious_Side_Effects (N : Node_Id) return Boolean; -- This is a simple minded function for determining whether an expression -- has no obvious side effects. It is used only for determining whether @@ -1518,6 +1537,17 @@ package Sem_Util is function Is_Container_Aggregate (Exp : Node_Id) return Boolean; -- Is the given expression a container aggregate? + function Is_Copy_Constructor (Spec_Id : Entity_Id) return Boolean; + -- Return True if the specification Spec_Id denotes a copy constructor: a + -- constructor procedure with two formal parameters of the underlying type, + -- where the first formal is 'in out', and the second is 'in'. Many + -- additional defaulted parameters are permitted. + + function Is_Copy_Constructor_Call (N : Node_Id) return Boolean; + -- Return True if N is a 'Make attribute reference with a single actual + -- parameter of the same type. Optionally, the only actual could be a + -- parameter association named "From". + function Is_Extended_Access_Type (Ent : Entity_Id) return Boolean; -- Ent is any entity. Returns True if Ent is a type (or a subtype thereof) -- for which the Extended_Access aspect has been specified, either diff --git a/gcc/ada/snames.ads-tmpl b/gcc/ada/snames.ads-tmpl index 4d129269fef7..725dc8e674a2 100644 --- a/gcc/ada/snames.ads-tmpl +++ b/gcc/ada/snames.ads-tmpl @@ -830,6 +830,7 @@ package Snames is Name_Exception_Raised : constant Name_Id := N + $; Name_External_Name : constant Name_Id := N + $; Name_Form : constant Name_Id := N + $; + Name_From : constant Name_Id := N + $; Name_Gcc : constant Name_Id := N + $; Name_General : constant Name_Id := N + $; Name_Gnat : constant Name_Id := N + $; @@ -897,6 +898,7 @@ package Snames is Name_Runtime : constant Name_Id := N + $; Name_SB : constant Name_Id := N + $; Name_Section : constant Name_Id := N + $; + Name_Self : constant Name_Id := N + $; Name_Semaphore : constant Name_Id := N + $; Name_Simple_Barriers : constant Name_Id := N + $; Name_SPARK : constant Name_Id := N + $;
