https://gcc.gnu.org/g:2cc46e7573c9308ec215b4aad5740e8226cfc7ac
commit r16-6628-g2cc46e7573c9308ec215b4aad5740e8226cfc7ac Author: Denis Mazzucato <[email protected]> Date: Mon Dec 8 14:09:12 2025 +0100 ada: Fix parameterless constructors This patch fix support for parameterless constructors. Specifically, it forbids calling the parameterless constructor when no explicit one has been declared, and when the parameterless one has been explicitly removed. Furthermore, by freezing constructors as predefined operations, it is now possible to use them in global object declarations right after the record type declaration. gcc/ada/ChangeLog: * exp_ch3.adb (Build_Init_Procedure): Remove call to constructors. (Build_Default_Simple_Initialization): Implicit call to parameterless constructors in new allocations. (Expand_Freeze_Record_Type): Freeze constructors as we would freeze predefined operations. (Constructor_Freeze): Freeze all constructors. * sem_attr.adb (Analyze_Attribute): Handle missing parameterless constructors. * sem_ch3.adb: The default constructor is now called parameterless. * sem_util.adb (Find_Matching_Constructor): Return the constructor matching the given condition. Before it was just checking its existence. (Has_Copy_Constructor): Move it upward to maintain alphabetic order of utility subprograms. (Has_Parameterless_Constructor): The default constructor is now called parameterless. (Has_Explicit_Constructor): New utility to check for constructors defined by the user. Used to understand if an implicit parameterless constructor exists. (Is_Copy_Constructor): Refactor easier control flow. (Is_Parameterless_Constructor): New utility to check if a constructor has a profile compatible with the parameterless constructor. * sem_util.ads: Likewise. Diff: --- gcc/ada/exp_ch3.adb | 89 ++++++++++++++++------------ gcc/ada/sem_attr.adb | 30 ++++++++-- gcc/ada/sem_ch3.adb | 4 +- gcc/ada/sem_util.adb | 163 ++++++++++++++++++++++++++++++--------------------- gcc/ada/sem_util.ads | 52 +++++++++------- 5 files changed, 208 insertions(+), 130 deletions(-) diff --git a/gcc/ada/exp_ch3.adb b/gcc/ada/exp_ch3.adb index 6a0c0eee7fb8..d233be85507a 100644 --- a/gcc/ada/exp_ch3.adb +++ b/gcc/ada/exp_ch3.adb @@ -384,6 +384,10 @@ package body Exp_Ch3 is -- Freeze entities of all predefined primitive operations. This is needed -- because the bodies of these operations do not normally do any freezing. + function Constructor_Freeze (Typ : Entity_Id) return List_Id; + -- Freeze all constructors of the type Tag_Typ. Otherwise, constructors + -- would not be available at freeze point. + -------------------------- -- Adjust_Discriminants -- -------------------------- @@ -1389,6 +1393,19 @@ package body Exp_Ch3 is -- is imported or not. if not Restriction_Active (No_Default_Initialization) then + -- If the type requires construction and the object being + -- initialized is an allocator that comes from source, then use + -- the parameterless constructor. + + if Nkind (N) = N_Allocator + and then Comes_From_Source (N) + and then Needs_Construction (Typ) + then + return + Make_Attribute_Reference (Loc, + Prefix => New_Occurrence_Of (Typ, Loc), + Attribute_Name => Name_Make); + end if; -- If the values of the components are compile-time known, use -- their prebuilt aggregate form directly. @@ -3398,40 +3415,6 @@ package body Exp_Ch3 is if Parent_Subtype_Renaming_Discrims then Append_List_To (Body_Stmts, Build_Init_Call_Thru (Parameters)); - elsif Needs_Construction (Rec_Type) then - if Has_Default_Constructor (Rec_Type) then - -- The 'Make attribute reference (with no arguments) will - -- generate a call to the one-parameter constructor procedure. - - Append_To (Body_Stmts, - Make_Assignment_Statement (Loc, - Name => New_Occurrence_Of - (Defining_Identifier (First (Parameters)), Loc), - Expression => Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Rec_Type, Loc), - Attribute_Name => Name_Make))); - else - -- No constructor procedure with an appropriate profile - -- is available, so raise Program_Error. - -- - -- We could instead do nothing here, since the absence of a - -- one-parameter constructor procedure should trigger other - -- legality checks which should statically ensure that - -- the init proc we are constructing here will never be - -- called. So a bit of "belt and suspenders" here. - -- If this raise statement is ever executed, that probably - -- means that some compile-time legality check is not - -- implemented, and that the program should have instead - -- failed to compile. - -- Because this raise statement should never be executed, it - -- seems ok to pass in a dubious Reason parameter instead of - -- declaring a new RT_Exception_Code value. - - Append_To (Body_Stmts, - Make_Raise_Program_Error (Loc, - Reason => PE_Explicit_Raise)); - end if; - elsif Nkind (Type_Definition (N)) = N_Record_Definition then Build_Discriminant_Assignments (Body_Stmts); @@ -4024,7 +4007,7 @@ package body Exp_Ch3 is -- attribute. elsif Needs_Construction (Typ) - and then Has_Default_Constructor (Typ) + and then Has_Parameterless_Constructor (Typ) then Set_Expression (Decl, Make_Attribute_Reference (Loc, @@ -6685,6 +6668,10 @@ package body Exp_Ch3 is Build_Untagged_Record_Equality (Typ); end if; + -- Freeze constructors as predefined operations + + Append_Freeze_Actions (Typ, Constructor_Freeze (Typ)); + -- Before building the record initialization procedure, if we are -- dealing with a concurrent record value type, then we must go through -- the discriminants, exchanging discriminals between the concurrent @@ -7801,7 +7788,7 @@ package body Exp_Ch3 is if No (Expr) and then Constant_Present (N) and then (not Needs_Construction (Typ) - or else not Has_Default_Constructor (Typ)) + or else not Has_Parameterless_Constructor (Typ)) then return; end if; @@ -13153,6 +13140,36 @@ package body Exp_Ch3 is return Res; end Predefined_Primitive_Freeze; + ------------------------ + -- Constructor_Freeze -- + ------------------------ + + function Constructor_Freeze (Typ : Entity_Id) return List_Id is + Res : constant List_Id := New_List; + Cursor : Entity_Id; + Frnodes : List_Id; + + begin + if not Needs_Construction (Typ) then + return No_List; + end if; + + Cursor := + Get_Name_Entity_Id + (Direct_Attribute_Definition_Name (Typ, Name_Constructor)); + while Present (Cursor) loop + Frnodes := Freeze_Entity (Cursor, Typ); + + if Present (Frnodes) then + Append_List_To (Res, Frnodes); + end if; + + Cursor := Homonym (Cursor); + end loop; + + return Res; + end Constructor_Freeze; + ------------------------- -- Stream_Operation_OK -- ------------------------- diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index 36ad644ef135..b4d5f38d68aa 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -5296,14 +5296,34 @@ package body Sem_Attr is Next (Expr); end loop; - if not Is_Copy_Constructor_Call (N) - and then not Needs_Construction (Entity (P)) - then + if 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)); + elsif not Needs_Construction (Entity (P)) + or else not Has_Parameterless_Constructor (Entity (P)) + then + Error_Msg_NE ("no parameterless constructor for&", N, Entity (P)); + + -- In case the parameterless constructor was explicitly removed, a + -- more specific error message is provided. + + if Has_Parameterless_Constructor (Entity (P), + Allow_Removed => True) + then + declare + function Find_Parameterless_Constructor + is new Find_Matching_Constructor + (Is_Parameterless_Constructor); + + Removed_Parameterless : constant Entity_Id := + Find_Parameterless_Constructor (Entity (P), + Allow_Removed => True); + begin + Error_Msg_NE ("//explicitly removed at#", + N, Removed_Parameterless); + end; + end if; end if; end; diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 84c69191cb67..350f26550c18 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -5252,11 +5252,11 @@ package body Sem_Ch3 is elsif Needs_Construction (T) and then not Has_Init_Expression (N) - and then not Has_Default_Constructor (T) + and then not Has_Parameterless_Constructor (T) and then not Suppress_Initialization (Id) and then Comes_From_Source (N) then - Error_Msg_NE ("no default constructor for&", + Error_Msg_NE ("no parameterless constructor for&", Object_Definition (N), T); end if; diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index 31bcd98d4689..9cc4af9dc758 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -9153,6 +9153,40 @@ package body Sem_Util is raise Program_Error; end Find_Loop_In_Conditional_Block; + ------------------------------- + -- Find_Matching_Constructor -- + ------------------------------- + + function Find_Matching_Constructor + (Typ : Entity_Id; Allow_Removed : Boolean) return Entity_Id + is + Cursor : Entity_Id; + begin + pragma Assert (Is_Type (Typ)); + if not Needs_Construction (Typ) then + return Empty; + 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 Cursor; + end if; + + Cursor := Homonym (Cursor); + end loop; + + return Empty; + end Find_Matching_Constructor; + -------------------------- -- Find_Overlaid_Entity -- -------------------------- @@ -11819,6 +11853,19 @@ package body Sem_Util is Has_Compatible_Alignment_Internal (Obj, Expr, Layout_Done, Unknown); end Has_Compatible_Alignment; + -------------------------- + -- Has_Copy_Constructor -- + -------------------------- + + function Has_Copy_Constructor + (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean + is + function Find_Copy_Constructor + is new Find_Matching_Constructor (Is_Copy_Constructor); + begin + return Present (Find_Copy_Constructor (Typ, Allow_Removed)); + end Has_Copy_Constructor; + ---------------------- -- Has_Declarations -- ---------------------- @@ -11847,22 +11894,6 @@ package body Sem_Util is (First_Discriminant (Typ))); end Has_Defaulted_Discriminants; - ----------------------------- - -- Has_Default_Constructor -- - ----------------------------- - - 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)))); - - 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; - ------------------- -- Has_Denormals -- ------------------- @@ -12316,18 +12347,18 @@ package body Sem_Util is end if; end Has_Enabled_Property; - -------------------------- - -- Has_Copy_Constructor -- - -------------------------- + ------------------------------ + -- Has_Explicit_Constructor -- + ------------------------------ - function Has_Copy_Constructor + function Has_Explicit_Constructor (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean is - function Internal_Has_Copy_Constructor - is new Has_Matching_Constructor (Is_Copy_Constructor); + function Find_Explicit_Constructor + is new Find_Matching_Constructor (Comes_From_Source); begin - return Internal_Has_Copy_Constructor (Typ, Allow_Removed); - end Has_Copy_Constructor; + return Present (Find_Explicit_Constructor (Typ, Allow_Removed)); + end Has_Explicit_Constructor; ------------------------------------- -- Has_Full_Default_Initialization -- @@ -12627,40 +12658,6 @@ 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 -- --------------------------------- @@ -12805,24 +12802,18 @@ package body Sem_Util is -- More formals with default values are allowed afterwards declare - All_Defaults : Boolean := True; - Formal : Entity_Id := + 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; + return False; end if; Next_Formal (Formal); end loop; - - if All_Defaults then - return True; - end if; end; + return True; end if; - return False; end Is_Copy_Constructor; @@ -12919,6 +12910,19 @@ package body Sem_Util is Is_Ignored (N) and then not GNATprove_Mode and then not CodePeer_Mode; end Is_Ignored_In_Codegen; + ----------------------------------- + -- Has_Parameterless_Constructor -- + ----------------------------------- + + function Has_Parameterless_Constructor + (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean + is + function Find_Default_Constructor + is new Find_Matching_Constructor (Is_Parameterless_Constructor); + begin + return Present (Find_Default_Constructor (Typ, Allow_Removed)); + end Has_Parameterless_Constructor; + --------------------------------- -- Side_Effect_Free_Statements -- --------------------------------- @@ -13198,6 +13202,31 @@ package body Sem_Util is and then Nkind (Node (First_Elmt (Constits))) = N_Null; end Has_Null_Refinement; + ---------------------------------- + -- Is_Parameterless_Constructor -- + ---------------------------------- + + function Is_Parameterless_Constructor + (Spec_Id : Entity_Id) return Boolean is + begin + if Is_Constructor (Spec_Id) then + -- More formals with default values are allowed afterwards + + declare + Formal : Entity_Id := Next_Formal (First_Formal (Spec_Id)); + begin + while Present (Formal) loop + if No (Default_Value (Formal)) then + return False; + end if; + Next_Formal (Formal); + end loop; + end; + return True; + end if; + return False; + end Is_Parameterless_Constructor; + ------------------------------------------ -- Has_Nonstatic_Class_Wide_Pre_Or_Post -- ------------------------------------------ diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index e7d4cd9f437b..b90d875594cf 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -919,6 +919,15 @@ package Sem_Util is -- attribute 'Loop_Entry are transformed into blocks. Parts of the original -- loop are nested within the block. + generic + with function Condition (E : Entity_Id) return Boolean; + function Find_Matching_Constructor + (Typ : Entity_Id; Allow_Removed : Boolean) return Entity_Id; + -- Find 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. + procedure Find_Overlaid_Entity (N : Node_Id; Ent : out Entity_Id; @@ -1400,18 +1409,19 @@ package Sem_Util is -- appropriate reaction of a caller to Known_Incompatible is to treat it as -- Unknown, but issue a warning that there may be an alignment error. + 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_Declarations (N : Node_Id) return Boolean; -- Determines if the node can have declarations function Has_Defaulted_Discriminants (Typ : Entity_Id) return Boolean; -- Simple predicate to test for defaulted discriminants - 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. -- Returns False if E is not a floating-point type. @@ -1427,12 +1437,11 @@ package Sem_Util is -- parameter for reading or returns an effectively volatile value for -- reading. - function Has_Copy_Constructor + function Has_Explicit_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. + -- Return True if a constructor has been explicitly declared by the user + -- for type Typ. 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 @@ -1481,15 +1490,6 @@ 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 @@ -1526,6 +1526,12 @@ package Sem_Util is function Has_Non_Null_Statements (L : List_Id) return Boolean; -- Return True if L has non-null statements + function Has_Parameterless_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 Side_Effect_Free_Statements (L : List_Id) return Boolean; -- Return True if L has no statements with side effects @@ -1577,6 +1583,12 @@ package Sem_Util is -- Context_Requires_NC = False; in that case, "Might_Be_Newly_Constructed" -- might be a more accurate name. + function Is_Parameterless_Constructor (Spec_Id : Entity_Id) return Boolean; + -- Return True if the specification Spec_Id denotes a parameterless + -- constructor: a constructor procedure with a single 'in out' formal + -- parameter of the underlying type. Many additional defaulted parameters + -- are permitted. + function Is_Prim_Of_Abst_Type_With_Nonstatic_CW_Pre_Post (Subp : Entity_Id) return Boolean; -- Return True if Subp is a primitive of an abstract type, where the
