The B940010 ACATS test includes some legality violations that GNAT was
failing to reject (at compile time). With this change these violations
are detected and appropriate error messages are produced. Most of the
required error messages that are not generated initially are because
splitting is required - that is a separate issue. Even after appropriate
splitting, the compiler was failing to detect the violations associated
with the L and N procedures for types Protected_3 and Protected_5.
Tested on x86_64-pc-linux-gnu, committed on trunk
2019-12-12 Steve Baird <ba...@adacore.com>
gcc/ada/
* sem_ch6.adb
(New_Overloaded_Entity.Check_Conforming_Paramters): Add new
Conformance_Type parameter. With the value of
Subtype_Conformant, the behavior of Check_Conforming_Parameters
is unchanged. The call in Matching_Entry_Or_Subprogram to
instead passes in Type_Conformant. This corresponds to the use
of "type conformant" in Ada RM 9.4(11.4/3).
(New_Overloaded_Entity.Has_Matching_Entry_Or_Subprogram): Add
new Normalized_First_Parameter_Type function to help in ignoring
the distinction between protected and access-to-protected first
parameters when checking prefixed-view profile matching. Replace
computations of the type of the first parameter with calls to
this function as appropriate.
--- gcc/ada/sem_ch6.adb
+++ gcc/ada/sem_ch6.adb
@@ -10487,9 +10487,10 @@ package body Sem_Ch6 is
is
function Check_Conforming_Parameters
(E1_Param : Node_Id;
- E2_Param : Node_Id) return Boolean;
+ E2_Param : Node_Id;
+ Ctype : Conformance_Type) return Boolean;
-- Starting from the given parameters, check that all the parameters
- -- of two entries or subprograms are subtype conformant. Used to skip
+ -- of two entries or subprograms are conformant. Used to skip
-- the check on the controlling argument.
function Matching_Entry_Or_Subprogram
@@ -10516,26 +10517,38 @@ package body Sem_Ch6 is
-- whose name matches the original name of Subp and has a profile
-- conformant with the profile of Subp; return Empty if not found.
+ function Normalized_First_Parameter_Type
+ (E : Entity_Id) return Entity_Id;
+ -- Return the type of the first parameter unless that type
+ -- is an anonymous access type, in which case return the
+ -- designated type. Used to treat anonymous-access-to-synchronized
+ -- the same as synchronized for purposes of checking for
+ -- prefixed view profile conflicts.
+
---------------------------------
-- Check_Conforming_Parameters --
---------------------------------
function Check_Conforming_Parameters
(E1_Param : Node_Id;
- E2_Param : Node_Id) return Boolean
+ E2_Param : Node_Id;
+ Ctype : Conformance_Type) return Boolean
is
Param_E1 : Node_Id := E1_Param;
Param_E2 : Node_Id := E2_Param;
begin
while Present (Param_E1) and then Present (Param_E2) loop
- if Ekind (Defining_Identifier (Param_E1)) /=
- Ekind (Defining_Identifier (Param_E2))
- or else not
+ if (Ctype >= Mode_Conformant) and then
+ Ekind (Defining_Identifier (Param_E1)) /=
+ Ekind (Defining_Identifier (Param_E2))
+ then
+ return False;
+ elsif not
Conforming_Types
(Find_Parameter_Type (Param_E1),
Find_Parameter_Type (Param_E2),
- Subtype_Conformant)
+ Ctype)
then
return False;
end if;
@@ -10568,7 +10581,8 @@ package body Sem_Ch6 is
and then
Check_Conforming_Parameters
(First (Parameter_Specifications (Parent (E))),
- Next (First (Parameter_Specifications (Parent (Subp)))))
+ Next (First (Parameter_Specifications (Parent (Subp)))),
+ Type_Conformant)
then
return E;
end if;
@@ -10608,7 +10622,8 @@ package body Sem_Ch6 is
and then
Check_Conforming_Parameters
(First (Parameter_Specifications (Parent (Ent))),
- Next (First (Parameter_Specifications (Parent (E)))))
+ Next (First (Parameter_Specifications (Parent (E)))),
+ Subtype_Conformant)
then
return E;
end if;
@@ -10662,6 +10677,21 @@ package body Sem_Ch6 is
return Empty;
end Matching_Original_Protected_Subprogram;
+ -------------------------------------
+ -- Normalized_First_Parameter_Type --
+ -------------------------------------
+
+ function Normalized_First_Parameter_Type
+ (E : Entity_Id) return Entity_Id
+ is
+ Result : Entity_Id := Etype (First_Entity (E));
+ begin
+ if Ekind (Result) = E_Anonymous_Access_Type then
+ Result := Designated_Type (Result);
+ end if;
+ return Result;
+ end Normalized_First_Parameter_Type;
+
-- Start of processing for Has_Matching_Entry_Or_Subprogram
begin
@@ -10672,20 +10702,23 @@ package body Sem_Ch6 is
if Comes_From_Source (E)
and then Is_Subprogram (E)
and then Present (First_Entity (E))
- and then Is_Concurrent_Record_Type (Etype (First_Entity (E)))
+ and then Is_Concurrent_Record_Type
+ (Normalized_First_Parameter_Type (E))
then
if Scope (E) =
Scope (Corresponding_Concurrent_Type
- (Etype (First_Entity (E))))
+ (Normalized_First_Parameter_Type (E)))
and then
Present
(Matching_Entry_Or_Subprogram
- (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ (Corresponding_Concurrent_Type
+ (Normalized_First_Parameter_Type (E)),
Subp => E))
then
Report_Conflict (E,
Matching_Entry_Or_Subprogram
- (Corresponding_Concurrent_Type (Etype (First_Entity (E))),
+ (Corresponding_Concurrent_Type
+ (Normalized_First_Parameter_Type (E)),
Subp => E));
return True;
end if;