When a dispatching operation overrides an inherited subprogram, it must
be subtype conformant with the inherited subprogram. Such check is not
performed by the frontend on overriding primitives of private types
which are declared before the full type declaration of the private type.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-09 Javier Miranda <mira...@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.--- gcc/ada/libgnat/g-exptty.adb
+++ gcc/ada/libgnat/g-exptty.adb
@@ -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);
--- gcc/ada/libgnat/g-exptty.ads
+++ gcc/ada/libgnat/g-exptty.ads
@@ -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;
--- gcc/ada/sem_ch6.adb
+++ gcc/ada/sem_ch6.adb
@@ -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);
--- gcc/ada/sem_disp.ads
+++ gcc/ada/sem_disp.ads
@@ -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
--- gcc/ada/sem_eval.adb
+++ gcc/ada/sem_eval.adb
@@ -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))
