[Ada] Missing check on private overriding of dispatching primitive

2020-06-09  Javier Miranda  <miranda@adacore.com>

gcc/ada/

	* sem_ch6.adb (New_Overloaded_Entity): Add missing call to check
	subtype conformance of overriding dispatching primitive.
	* sem_eval.adb (Subtypes_Statically_Match): Handle derivations
	of private subtypes.
	* libgnat/g-exptty.adb, libgnat/g-exptty.ads
	(Set_Up_Communications): Fix the profile since null-exclusion is
	missing in the access type formals.
	* sem_disp.ads (Check_Operation_From_Private_View): Adding
	documentation.
This commit is contained in:
Javier Miranda 2020-03-01 14:04:48 -05:00 committed by Pierre-Marie de Rodat
parent a2048d055b
commit 009668e31f
5 changed files with 47 additions and 12 deletions

View File

@ -314,9 +314,9 @@ package body GNAT.Expect.TTY is
overriding procedure Set_Up_Communications
(Pid : in out TTY_Process_Descriptor;
Err_To_Out : Boolean;
Pipe1 : access Pipe_Type;
Pipe2 : access Pipe_Type;
Pipe3 : access Pipe_Type)
Pipe1 : not null access Pipe_Type;
Pipe2 : not null access Pipe_Type;
Pipe3 : not null access Pipe_Type)
is
pragma Unreferenced (Err_To_Out, Pipe1, Pipe2, Pipe3);

View File

@ -116,9 +116,9 @@ private
procedure Set_Up_Communications
(Pid : in out TTY_Process_Descriptor;
Err_To_Out : Boolean;
Pipe1 : access Pipe_Type;
Pipe2 : access Pipe_Type;
Pipe3 : access Pipe_Type);
Pipe1 : not null access Pipe_Type;
Pipe2 : not null access Pipe_Type;
Pipe3 : not null access Pipe_Type);
procedure Set_Up_Parent_Communications
(Pid : in out TTY_Process_Descriptor;

View File

@ -11177,6 +11177,18 @@ package body Sem_Ch6 is
Inherit_Subprogram_Contract (E, S);
end if;
-- When a dispatching operation overrides an inherited
-- subprogram, it shall be subtype conformant with the
-- inherited subprogram (RM 3.9.2 (10.2)).
if Comes_From_Source (E)
and then Is_Dispatching_Operation (E)
and then Find_Dispatching_Type (S)
= Find_Dispatching_Type (E)
then
Check_Subtype_Conformant (E, S);
end if;
if Comes_From_Source (E) then
Check_Overriding_Indicator (E, S, Is_Primitive => False);

View File

@ -64,11 +64,11 @@ package Sem_Disp is
-- this call actually do???
procedure Check_Operation_From_Private_View (Subp, Old_Subp : Entity_Id);
-- Add Old_Subp to the list of primitive operations of the corresponding
-- tagged type if it is the full view of a private tagged type. The Alias
-- of Old_Subp is adjusted to point to the inherited procedure of the
-- full view because it is always this one which has to be called.
-- What is Subp used for???
-- No action performed if Subp is not an alias of a dispatching operation.
-- Add Old_Subp (if not already present) to the list of primitives of the
-- tagged type T of Subp if T is the full view of a private tagged type.
-- The Alias of Old_Subp is adjusted to point to the inherited procedure
-- of the full view because it is always this one which has to be called.
function Covered_Interface_Op (Prim : Entity_Id) return Entity_Id;
-- Returns the interface primitive that Prim covers, when its controlling

View File

@ -6092,6 +6092,29 @@ package body Sem_Eval is
elsif Has_Discriminants (T1) or else Has_Discriminants (T2) then
-- Handle derivations of private subtypes. For example S1 statically
-- matches the full view of T1 in the following example:
-- type T1(<>) is new Root with private;
-- subtype S1 is new T1;
-- overriding proc P1 (P : S1);
-- private
-- type T1 (D : Disc) is new Root with ...
if Ekind (T2) = E_Record_Subtype_With_Private
and then not Has_Discriminants (T2)
and then Partial_View_Has_Unknown_Discr (T1)
and then Etype (T2) = T1
then
return True;
elsif Ekind (T1) = E_Record_Subtype_With_Private
and then not Has_Discriminants (T1)
and then Partial_View_Has_Unknown_Discr (T2)
and then Etype (T1) = T2
then
return True;
-- Because of view exchanges in multiple instantiations, conformance
-- checking might try to match a partial view of a type with no
-- discriminants with a full view that has defaulted discriminants.
@ -6099,7 +6122,7 @@ package body Sem_Eval is
-- which must exist because we know that the two subtypes have the
-- same base type.
if Has_Discriminants (T1) /= Has_Discriminants (T2) then
elsif Has_Discriminants (T1) /= Has_Discriminants (T2) then
if In_Instance then
if Is_Private_Type (T2)
and then Present (Full_View (T2))