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

diff --git a/gcc/ada/libgnat/g-exptty.adb b/gcc/ada/libgnat/g-exptty.adb
index ae2d64a2fdf9cb707e56b051f87325aa5337e8cb..bc239e48651663328309e9f6510234d41c780865 100644 (file)
--- a/gcc/ada/libgnat/g-exptty.adb
+++ b/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);
 

diff --git a/gcc/ada/libgnat/g-exptty.ads b/gcc/ada/libgnat/g-exptty.ads
index 5f1736cb68fed4577bbcbc2c704b98b82a296214..ede147caa2d98c7e73c2bb394ab3c583a7b2ff57 100644 (file)
--- a/gcc/ada/libgnat/g-exptty.ads
+++ b/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;

diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb
index 860db03f78eae24d1572488ea72a0f2473269565..69494a08584d4fa42e23555e867ab1c5e1bccf10 100644 (file)
--- a/gcc/ada/sem_ch6.adb
+++ b/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);
 

diff --git a/gcc/ada/sem_disp.ads b/gcc/ada/sem_disp.ads
index 19539306d57310df9779eaa9f8b884e0bbeb5181..993ec10f38c3d9ff8d38ca4d8c8fe80bf3b2fcb9 100644 (file)
--- a/gcc/ada/sem_disp.ads
+++ b/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

diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 2857c536706d03420b8228fb101066c0aead3ee7..879f0c1986f6c41d6c10d452accb3fbc0a233162 100644 (file)
--- a/gcc/ada/sem_eval.adb
+++ b/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))