[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.

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

@@ -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

@@ -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

@@ -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

@@ -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))