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 --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 6adc627b48a319686ac4020a9997010dfcc20667..38c009d0fd8d06f44585a32a7c52a00925bced91 100644 (file)
--- 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 160f1a3157518b13fb2f847b2fe08c055e654a55..ac9042ccc58e7c5dfc84c9d8f1cb50fa0f876277 100644 (file)
--- 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;