[Ada] ACATS 4.1J - B854003 - Subtype conformance check missed

2020-06-18  Arnaud Charlet  <charlet@adacore.com>

gcc/ada/

	* sem_ch6.ads, sem_ch6.adb (Check_Formal_Conformance): New
	subprogram.
	(Check_Conformance): Move code to Check_Formal_Conformance.
	* sem_ch8.adb (Analyze_Subprogram_Renaming): Check for formal
	conformance when needed.

3 files changed, 46 insertions, 11 deletions

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index fa9bb5d..96099e7 100644
--- a/gcc/ada/sem_ch6.adb
+++ b/gcc/ada/sem_ch6.adb
@@ -5734,16 +5734,8 @@ package body Sem_Ch6 is
             end if;
 
             return;
-
-         elsif Is_Formal_Subprogram (Old_Id)
-           or else Is_Formal_Subprogram (New_Id)
-           or else (Is_Subprogram (New_Id)
-                     and then Present (Alias (New_Id))
-                     and then Is_Formal_Subprogram (Alias (New_Id)))
-         then
-            Conformance_Error
-              ("\formal subprograms are not subtype conformant "
-               & "(RM 6.3.1 (17/3))");
+         else
+            Check_Formal_Subprogram_Conformance (New_Id, Old_Id, Err_Loc);
          end if;
       end if;
 
@@ -6516,6 +6508,37 @@ package body Sem_Ch6 is
       end if;
    end Check_Discriminant_Conformance;
 
+   -----------------------------------------
+   -- Check_Formal_Subprogram_Conformance --
+   -----------------------------------------
+
+   procedure Check_Formal_Subprogram_Conformance
+     (New_Id  : Entity_Id;
+      Old_Id  : Entity_Id;
+      Err_Loc : Node_Id := Empty)
+   is
+      N : Node_Id;
+   begin
+      if Is_Formal_Subprogram (Old_Id)
+        or else Is_Formal_Subprogram (New_Id)
+        or else (Is_Subprogram (New_Id)
+                  and then Present (Alias (New_Id))
+                  and then Is_Formal_Subprogram (Alias (New_Id)))
+      then
+         if Present (Err_Loc) then
+            N := Err_Loc;
+         else
+            N := New_Id;
+         end if;
+
+         Error_Msg_Sloc := Sloc (Old_Id);
+         Error_Msg_N ("not subtype conformant with declaration#!", N);
+         Error_Msg_NE
+           ("\formal subprograms are not subtype conformant "
+            & "(RM 6.3.1 (17/3))", N, New_Id);
+      end if;
+   end Check_Formal_Subprogram_Conformance;
+
    ----------------------------
    -- Check_Fully_Conformant --
    ----------------------------
diff --git a/gcc/ada/sem_ch6.ads b/gcc/ada/sem_ch6.ads
index 653bfca..81b4821 100644
--- a/gcc/ada/sem_ch6.ads
+++ b/gcc/ada/sem_ch6.ads
@@ -69,6 +69,16 @@ package Sem_Ch6 is
    --  the source location of the partial view, which may be different than
    --  Prev in the case of private types.
 
+   procedure Check_Formal_Subprogram_Conformance
+     (New_Id  : Entity_Id;
+      Old_Id  : Entity_Id;
+      Err_Loc : Node_Id := Empty);
+   --  Check RM 6.3.1(17/3): the profile of a generic formal subprogram is not
+   --  subtype conformant with any other profile and post an error message if
+   --  either New_Id or Old_Id denotes a formal subprogram, with the flag being
+   --  placed on the Err_Loc node if it is specified, and on New_Id if not. See
+   --  also spec of Check_Fully_Conformant below for New_Id and Old_Id usage.
+
    procedure Check_Fully_Conformant
      (New_Id  : Entity_Id;
       Old_Id  : Entity_Id;
diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb
index acb5b21..4e85a15 100644
--- a/gcc/ada/sem_ch8.adb
+++ b/gcc/ada/sem_ch8.adb
@@ -3171,7 +3171,7 @@ package body Sem_Ch8 is
 
       Set_Kill_Elaboration_Checks (New_S, True);
 
-      --  If we had a previous error, indicate a completely is present to stop
+      --  If we had a previous error, indicate a completion is present to stop
       --  junk cascaded messages, but don't take any further action.
 
       if Etype (Nam) = Any_Type then
@@ -3409,6 +3409,8 @@ package body Sem_Ch8 is
 
                if Original_Subprogram (Old_S) = Rename_Spec then
                   Error_Msg_N ("unfrozen subprogram cannot rename itself ", N);
+               else
+                  Check_Formal_Subprogram_Conformance (New_S, Old_S, Spec);
                end if;
             else
                Check_Subtype_Conformant (New_S, Old_S, Spec);