https://gcc.gnu.org/g:31d9329f11ad93b3deb0c5f83f8a6a75a31f26b7
commit r17-800-g31d9329f11ad93b3deb0c5f83f8a6a75a31f26b7 Author: Javier Miranda <[email protected]> Date: Fri Feb 13 12:09:34 2026 +0000 ada: Overriding of First_Controlling_Parameter tagged type primitive Implement rule for overriding primitives of tagged types that have the First_Controlling_Parameter aspect. gcc/ada/ChangeLog: * sem_ch3.adb (Derive_Subprogram): Do not replace the type when Derived_Type inherits the first controlling parameter aspect and it is not the first formal of this operation. * sem_disp.adb (Check_Controlling_Formals): For overriding primitives of types with the first controlling parameter aspect inherit controlling formals of the overridden parent primitive. Diff: --- gcc/ada/sem_ch3.adb | 17 +++++++++++++++++ gcc/ada/sem_disp.adb | 23 ++++++++++++++++++++--- 2 files changed, 37 insertions(+), 3 deletions(-) diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index 6adc627b48a3..38c009d0fd8d 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -16870,6 +16870,23 @@ package body Sem_Ch3 is if Present (Formal_Of_Actual) then Replace_Type (Formal_Of_Actual, New_Formal); Next_Formal (Formal_Of_Actual); + + -- Do not replace the type when Derived_Type inherits the first + -- controlling parameter aspect and this is not the first formal + -- of this operation. The exception to this common case is when + -- this is a controlling formal; this case corresponds with an + -- inherited operation of an ancestor that does not have the + -- first controlling parameter aspect. + + elsif Is_Tagged_Type (Parent_Type) + and then Has_First_Controlling_Parameter_Aspect (Parent_Type) + and then Formal /= First_Formal (Parent_Subp) + and then not Is_Controlling_Formal (Formal) + and then Is_Dispatching_Operation (Parent_Subp) + and then not Is_Predefined_Dispatching_Operation (Parent_Subp) + then + null; + else Replace_Type (Formal, New_Formal); end if; diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 160f1a315751..ac9042ccc58e 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -292,8 +292,9 @@ package body Sem_Disp is (Typ : Entity_Id; Subp : Entity_Id) is - Formal : Entity_Id; - Ctrl_Type : Entity_Id; + Ctrl_Type : Entity_Id; + Formal : Entity_Id; + Ovr_Formal : Entity_Id := Empty; begin -- We skip the check for thunks @@ -302,6 +303,10 @@ package body Sem_Disp is return; end if; + if Present (Overridden_Operation (Subp)) then + Ovr_Formal := First_Formal (Overridden_Operation (Subp)); + end if; + Formal := First_Formal (Subp); while Present (Formal) loop Ctrl_Type := Empty; @@ -354,7 +359,15 @@ package body Sem_Disp is (Ekind (Subp) = E_Function and then Is_Operator_Name (Chars (Subp))) then - Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); + -- Overriding a parent primitive + + if Present (Ovr_Formal) + and then not Is_Controlling_Formal (Ovr_Formal) + then + null; + else + Ctrl_Type := Check_Controlling_Type (Etype (Formal), Subp); + end if; end if; if Present (Ctrl_Type) then @@ -434,6 +447,10 @@ package body Sem_Disp is end if; end if; + if Present (Overridden_Operation (Subp)) then + Next_Formal (Ovr_Formal); + end if; + Next_Formal (Formal); end loop;
