From 424ce99fb53c994ba56f99e4b5513dc19e897463 Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 23 Apr 2020 14:46:27 -0400 Subject: [PATCH] [Ada] ACATS 4.1J - B854003 - Subtype conformance check missed 2020-06-18 Arnaud Charlet 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. --- gcc/ada/sem_ch6.adb | 43 +++++++++++++++++++++++++++++++++---------- gcc/ada/sem_ch6.ads | 10 ++++++++++ gcc/ada/sem_ch8.adb | 4 +++- 3 files changed, 46 insertions(+), 11 deletions(-) diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index fa9bb5db5cf..96099e77b43 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 653bfcae61e..81b4821d576 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 acb5b216733..4e85a1508d7 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);