https://gcc.gnu.org/g:dbdd7aa2ee5c9a5842425d4772d427639a6f0be8
commit r17-1742-gdbdd7aa2ee5c9a5842425d4772d427639a6f0be8 Author: Javier Miranda <[email protected]> Date: Sat Jun 6 16:09:41 2026 +0000 ada: Add support for abstract constructors A constructor may be defined abstract in the public part of a package to hide it, but it must be defined in the private part of the package. gcc/ada/ChangeLog: * par-ch6.adb (P_Subprogram): Add missing support for direct attribute definition in abstract subprogram declarations. * sem_attr.adb (Check_Hidden_Abstract_Constructor_Call): New local subprogram of Analyze_Attribute. (Analyze_Attribute) <Attribute_Make>: Add calls to the new local subprogram to detect and report wrong calls to abstract constructors; minor code restructure. * sem_ch3.adb (Process_Full_View): Propagate Needs_Construction from the partial view to the full view. * sem_ch4.adb (Extended_Primitive_Ops): Add callable constructors to the extended primitive operations when available; otherwise, add abstract constructors so that we can diagnose wrong calls to them. * sem_ch6.adb (Analyze_Direct_Attribute_Definition) <Name_Constructor>: add missing support for abstract constructors. Report an error on abstract constructors not declared in the visible part of a package. (New_Overloaded_Entity): Add support for a private constructor to complete a public abstract constructor and link them with the Overridden_Operation attribute. * sem_ch7.adb (Inspect_Abstract_Constructors_Completion): New subprogram that checks if every abstract constructor in the visible part of the package has a matching counterpart constructor in its private part. (Analyze_Package_Specification): After analysing private declarations, call Inspect_Abstract_Constructors_Completion. * sem_util.ads (Collect_Constructors): New subprogram that collects all non-hidden constructors into two lists: Callable (non-abstract) constructors, and abstract constructors. * sem_util.adb (Collect_Constructors): Ditto. Diff: --- gcc/ada/par-ch6.adb | 3 ++ gcc/ada/sem_attr.adb | 134 ++++++++++++++++++++++++++++++++++++++++----------- gcc/ada/sem_ch3.adb | 9 ++-- gcc/ada/sem_ch4.adb | 53 ++++++++++++++------ gcc/ada/sem_ch6.adb | 33 ++++++++++++- gcc/ada/sem_ch7.adb | 56 +++++++++++++++++++++ gcc/ada/sem_util.adb | 63 +++++++++++++++++++++++- gcc/ada/sem_util.ads | 7 +++ 8 files changed, 307 insertions(+), 51 deletions(-) diff --git a/gcc/ada/par-ch6.adb b/gcc/ada/par-ch6.adb index d4356ab1b907..2ec198293c50 100644 --- a/gcc/ada/par-ch6.adb +++ b/gcc/ada/par-ch6.adb @@ -644,6 +644,9 @@ package body Ch6 is Absdec_Node := New_Node (N_Abstract_Subprogram_Declaration, Token_Ptr); Set_Specification (Absdec_Node, Specification_Node); + Rewrite_Entity_If_Direct_Attribute_Def + (Name_Node, Specification_Node); + Pop_Scope_Stack; -- discard unneeded entry Scan; -- past ABSTRACT P_Aspect_Specifications (Absdec_Node, Semicolon => True); diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb index e038774849d8..bb1967de1e69 100644 --- a/gcc/ada/sem_attr.adb +++ b/gcc/ada/sem_attr.adb @@ -383,6 +383,11 @@ package body Sem_Attr is -- Verify that prefix of attribute N is a float type and that -- two attribute expressions are present. + procedure Check_Hidden_Abstract_Constructor_Call (Ctor_Call : Node_Id); + -- If Ctor_Call is a call to a hidden constructor then search in the + -- homonym chain for the counterpart abstract entity to report it as + -- non-callable (if found). + procedure Check_Integer_Type; -- Verify that prefix of attribute N is an integer type @@ -2367,6 +2372,85 @@ package body Sem_Attr is Check_E2; end Check_Floating_Point_Type_2; + -------------------------------------------- + -- Check_Hidden_Abstract_Constructor_Call -- + -------------------------------------------- + + procedure Check_Hidden_Abstract_Constructor_Call (Ctor_Call : Node_Id) is + Is_Copy_Ctor_Call : constant Boolean := + Is_Copy_Constructor_Call (Ctor_Call); + + function Find_Copy_Ctor is + new Find_Matching_Constructor (Is_Copy_Constructor); + -- Search for the copy constructor + + function Find_Parameterless_Ctor is + new Find_Matching_Constructor (Is_Parameterless_Constructor); + -- Search for the default constructor + + function Is_Target_Constructor (E : Entity_Id) return Boolean; + -- Relying on the value of Is_Copy_Ctor_Call, determine if E is + -- the target constructor of Ctor_Call. + + --------------------------- + -- Is_Target_Constructor -- + --------------------------- + + function Is_Target_Constructor (E : Entity_Id) return Boolean is + begin + if Is_Copy_Ctor_Call then + return Is_Copy_Constructor (E); + else + return Is_Parameterless_Constructor (E); + end if; + end Is_Target_Constructor; + + -- Local variables + + Ctor : Entity_Id; + Hom : Entity_Id; + Pref : constant Node_Id := Prefix (Ctor_Call); + + -- Start of processing for Check_Hidden_Abstract_Constructor_Call + + begin + -- Search for a target candidate skipping abstract constructors + + if Is_Copy_Ctor_Call then + Ctor := Find_Copy_Ctor (Entity (Pref), + Allow_Removed => False); + else + Ctor := Find_Parameterless_Ctor (Entity (Pref), + Allow_Removed => False); + end if; + + -- If the target candidate is hidden then traverse the homonym + -- chain searching for the counterpart abstract entity (if + -- previously defined) to report it as non-callable. + + if Present (Ctor) and then Is_Hidden (Ctor) then + Hom := Homonym (Ctor); + + while Present (Hom) + and then Scope (Hom) = Scope (Ctor) + loop + if Is_Constructor (Hom) + and then Is_Abstract_Subprogram (Hom) + and then Is_Target_Constructor (Hom) + then + Error_Msg_Sloc := Sloc (Hom); + Error_Msg_NE + ("cannot call abstract constructor& declared#", + Ctor_Call, Hom); + Set_Etype (Ctor_Call, Any_Type); + exit; + end if; + + Hom := Homonym (Hom); + end loop; + end if; + end Check_Hidden_Abstract_Constructor_Call; + ------------------------ -- Check_Integer_Type -- ------------------------ @@ -5408,8 +5492,10 @@ package body Sem_Attr is when Attribute_Make => declare Expr : Entity_Id; + begin if not All_Extensions_Allowed then + Error_Msg_Name_1 := Aname; Error_Msg_GNAT_Extension ("attribute %", Loc); return; end if; @@ -5417,7 +5503,21 @@ package body Sem_Attr is Check_Type; Set_Etype (N, Etype (P)); - if Present (Exprs) then + -- Default parameterless constructor call + + if No (Exprs) then + if not Needs_Construction (Entity (P)) + or else not Has_Parameterless_Constructor (Entity (P)) + then + Error_Msg_NE + ("no parameterless constructor for&", N, Entity (P)); + else + Check_Hidden_Abstract_Constructor_Call (N); + end if; + + -- Constructor call with params + + else Expr := First (Exprs); while Present (Expr) loop if Nkind (Expr) = N_Parameter_Association then @@ -5432,13 +5532,14 @@ package body Sem_Attr is if not Needs_Construction (Entity (P)) then Error_Msg_NE ("no available constructor for&", N, Entity (P)); + elsif Is_Copy_Constructor_Call (N) then + Check_Hidden_Abstract_Constructor_Call (N); + -- Verify that the provided arguments are compatible with at least -- one constructor (checked by parameters count). Mismatched -- actuals will be caught later during resolution. - elsif not Is_Copy_Constructor_Call (N) - and then Comes_From_Source (N) - then + elsif Comes_From_Source (N) then declare Num_Args : constant Nat := List_Length (Exprs); @@ -5488,31 +5589,6 @@ package body Sem_Attr is end if; end; end if; - - 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 41d2d99d480e..f434ae3e92a0 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -10480,8 +10480,7 @@ package body Sem_Ch3 is -- Propagate information about constructor dependence from parent Set_Needs_Construction - (Derived_Type, - Needs_Construction (Parent_Type)); + (Derived_Type, Needs_Construction (Parent_Type)); end if; -- If the parent has primitive routines and may have not-seen-yet aspect @@ -19007,7 +19006,7 @@ package body Sem_Ch3 is -- Preserve aspect and iterator flags that may have been set on -- the partial view. - Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id)); + Set_Has_Delayed_Aspects (Prev, Has_Delayed_Aspects (Id)); Set_Has_Implicit_Dereference (Prev, Has_Implicit_Dereference (Id)); -- If no error, propagate freeze_node from private to full view. @@ -22498,6 +22497,10 @@ package body Sem_Ch3 is Set_Has_First_Controlling_Parameter_Aspect (Full_T); end if; + -- Propagate the constructor flag to the full view + + Set_Needs_Construction (Full_T, Needs_Construction (Priv_T)); + -- Propagate predicates to full type, and predicate function if already -- defined. It is not clear that this can actually happen? the partial -- view cannot be frozen yet, and the predicate function has not been diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index a8e5e36ff326..0bb74729aaef 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -10735,27 +10735,48 @@ 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; + 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); + Callable_Ctors : Elist_Id; + Abstract_Ctors : Elist_Id; + Elmt : Elmt_Id; + 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); + Collect_Constructors (T, Callable_Ctors, Abstract_Ctors); + + -- Add callable constructors (suppressing abstract + -- constructors to avoid reporting spurious ambiguity); + -- if no callable constructor is available then add + -- abstract constructors; required to allow subprogram + -- Check_Hidden_Abstract_Constructor_Call to detect + -- and report calls to them from outside their enclosing + -- package. + + declare + Ctors_To_Add : constant Elist_Id := + (if not Is_Empty_Elmt_List (Callable_Ctors) + then Callable_Ctors + else Abstract_Ctors); + + begin + Elmt := First_Elmt (Ctors_To_Add); + + if Present (Elmt) then + -- Copy list of primitives so it is not + -- affected for other uses. + + Op_List := New_Copy_Elist (Op_List); + Op_Found := True; + + while Present (Elmt) loop + Append_Elmt (Node (Elmt), Op_List); + Next_Elmt (Elmt); + end loop; end if; - Next_Entity (Cursor); - end loop; + end; end; end if; diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index dab3b9ac41c9..d2fc515596b9 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -5306,7 +5306,9 @@ package body Sem_Ch6 is -- If missing, add a default initialization aspect for this -- constructor's body stub: Initialize => (others => <>). - if Parent_Kind (N) not in N_Subprogram_Declaration then + if Parent_Kind (N) not in N_Subprogram_Declaration + | N_Abstract_Subprogram_Declaration + then if not Has_Aspect (Designator, Aspect_Initialize) then Add_Default_Initialize_Aspect; end if; @@ -5347,6 +5349,17 @@ package body Sem_Ch6 is Error_Msg_N ("& must be defined before freezing#", Designator); + elsif Parent_Kind (N) = N_Abstract_Subprogram_Declaration + and then + (In_Private_Part (Current_Scope) + or else + Parent_Kind (Enclosing_Package_Or_Subprogram (Designator)) + /= N_Package_Specification) + then + Error_Msg_N + ("abstract constructor must be defined in " + & "the public part of a package", Designator); + elsif Parent_Kind (Enclosing_Package_Or_Subprogram (Designator)) /= N_Package_Specification then @@ -12932,6 +12945,24 @@ package body Sem_Ch6 is then null; + -- An abstract constructor declared in the visible part of a + -- package may be given its non-abstract declaration in the + -- private part of the package. Accept it without conflict. + + elsif Is_Abstract_Subprogram (E) + and then Is_Constructor (E) + and then Is_Constructor (S) + and then Scope (S) = Scope (E) + and then Is_Private_Declaration (S) + then + Enter_Overloaded_Entity (S); + Set_Overridden_Operation (S, E); + + -- There is no need to check if it is a primitive because + -- constructors are not primitive subprograms. + + goto Check_Inequality; + -- Here we have a real error (identical profile) else diff --git a/gcc/ada/sem_ch7.adb b/gcc/ada/sem_ch7.adb index 90f851e57abb..2709f0eb66a2 100644 --- a/gcc/ada/sem_ch7.adb +++ b/gcc/ada/sem_ch7.adb @@ -1337,6 +1337,11 @@ package body Sem_Ch7 is -- primitive equality operator and, if so, make it so that it will be -- used as the predefined operator of the private view of the record. + procedure Inspect_Abstract_Constructors_Completion (Id : Entity_Id); + -- For each abstract constructor in the visible part of package Id, + -- verify that a non-abstract counterpart exists in the private part + -- of the package, and emit an error for each that lacks one. + procedure Install_Parent_Private_Declarations (Inst_Id : Entity_Id); -- Given the package entity of a generic package instantiation or -- formal package whose corresponding generic is a child unit, installs @@ -1449,6 +1454,50 @@ package body Sem_Ch7 is end if; end Is_Public_Child; + ---------------------------------------------- + -- Inspect_Abstract_Constructors_Completion -- + ---------------------------------------------- + + procedure Inspect_Abstract_Constructors_Completion (Id : Entity_Id) is + First_Priv : constant Entity_Id := First_Private_Entity (Id); + Vis_E : Entity_Id := First_Entity (Id); + + begin + while Present (Vis_E) and then Vis_E /= First_Priv loop + if Is_Constructor (Vis_E) + and then Is_Abstract_Subprogram (Vis_E) + then + declare + Hom : Entity_Id := Get_Name_Entity_Id (Chars (Vis_E)); + Found : Boolean := False; + + begin + while Present (Hom) + and then Scope (Hom) = Scope (Vis_E) + loop + if not Is_Abstract_Subprogram (Hom) + and then Is_Constructor (Hom) + and then Overridden_Operation (Hom) = Vis_E + then + Found := True; + exit; + end if; + + Hom := Homonym (Hom); + end loop; + + if not Found then + Error_Msg_N + ("abstract constructor has no declaration in " + & "the private part", Vis_E); + end if; + end; + end if; + + Next_Entity (Vis_E); + end loop; + end Inspect_Abstract_Constructors_Completion; + ---------------------------------------- -- Inspect_Unchecked_Union_Completion -- ---------------------------------------- @@ -1891,6 +1940,13 @@ package body Sem_Ch7 is Set_First_Private_Entity (Id, Next_Entity (L)); end if; + -- An abstract constructor declared in the visible part requires a + -- matching concrete constructor in the private part. + + if Core_Extensions_Allowed then + Inspect_Abstract_Constructors_Completion (Id); + end if; + E := First_Entity (Id); while Present (E) loop diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb index b22d735869f4..bed4e74793f8 100644 --- a/gcc/ada/sem_util.adb +++ b/gcc/ada/sem_util.adb @@ -5425,6 +5425,58 @@ package body Sem_Util is return States; end Collect_Body_States; + -------------------------- + -- Collect_Constructors -- + -------------------------- + + procedure Collect_Constructors + (Typ : Entity_Id; + Callable_Ctors : out Elist_Id; + Abstract_Ctors : out Elist_Id) + is + Typ_Scope : constant Entity_Id := Scope (Typ); + Boundary : constant Entity_Id := First_Private_Entity (Typ_Scope); + Cursor : Entity_Id; + + begin + Callable_Ctors := New_Elmt_List; + Abstract_Ctors := New_Elmt_List; + + -- Visible part: classify non-hidden constructors of Typ as + -- callable or abstract. + + Cursor := First_Entity (Typ_Scope); + while Present (Cursor) and then Cursor /= Boundary loop + if Is_Constructor (Cursor) + and then Etype (First_Formal (Cursor)) = Typ + and then not Is_Hidden (Cursor) + then + if Is_Abstract_Subprogram (Cursor) then + Append_Elmt (Cursor, Abstract_Ctors); + else + Append_Elmt (Cursor, Callable_Ctors); + end if; + end if; + + Next_Entity (Cursor); + end loop; + + -- Private part: abstract constructors cannot appear here; + -- all non-hidden constructors here are callable. + + Cursor := Boundary; + while Present (Cursor) loop + if Is_Constructor (Cursor) + and then Etype (First_Formal (Cursor)) = Typ + and then not Is_Hidden (Cursor) + then + Append_Elmt (Cursor, Callable_Ctors); + end if; + + Next_Entity (Cursor); + end loop; + end Collect_Constructors; + ------------------------ -- Collect_Interfaces -- ------------------------ @@ -11911,7 +11963,7 @@ package body Sem_Util is (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean is function Find_Copy_Constructor - is new Find_Matching_Constructor (Is_Copy_Constructor); + is new Find_Matching_Constructor (Is_Copy_Constructor); begin return Present (Find_Copy_Constructor (Typ, Allow_Removed)); end Has_Copy_Constructor; @@ -12866,16 +12918,20 @@ package body Sem_Util is declare Formal : Entity_Id := Next_Formal (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_Copy_Constructor; @@ -12980,7 +13036,7 @@ package body Sem_Util is (Typ : Entity_Id; Allow_Removed : Boolean := False) return Boolean is function Find_Default_Constructor - is new Find_Matching_Constructor (Is_Parameterless_Constructor); + is new Find_Matching_Constructor (Is_Parameterless_Constructor); begin return Present (Find_Default_Constructor (Typ, Allow_Removed)); end Has_Parameterless_Constructor; @@ -13281,11 +13337,14 @@ package body Sem_Util is 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; diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads index 1821fd9796e4..2c2eb1a3678e 100644 --- a/gcc/ada/sem_util.ads +++ b/gcc/ada/sem_util.ads @@ -491,6 +491,13 @@ package Sem_Util is -- Gather the entities of all abstract states and objects declared in the -- body state space of package body Body_Id. + procedure Collect_Constructors + (Typ : Entity_Id; + Callable_Ctors : out Elist_Id; + Abstract_Ctors : out Elist_Id); + -- Collect in a single pass all non-hidden constructors of Typ in two + -- lists: Callable_Ctors (non-abstract) and Abstract_Ctors. + procedure Collect_Interfaces (T : Entity_Id; Ifaces_List : out Elist_Id;
