[Ada] Spurious error on private subtype of derived access type

This patch fixes a spurious type error on a dynamic predicate on a
subtype of a private type whose full view is a derived access type.
Prior to it, the base type of the subtype would appear to be the parent
type of the derived type instead of the derived type itself, leading to
problems downstream.

The following package must now compile quietly:

with S;

package T is
   type B_Pointer is private;
   Null_B_Pointer : constant B_Pointer;
   function OK (B : B_Pointer) return Boolean is (B /= Null_B_Pointer);
   subtype Valid_B_Pointer is B_Pointer
     with Dynamic_Predicate => OK (Valid_B_Pointer);
private
   type B_Pointer is new S.A_Pointer;
   Null_B_Pointer : constant B_Pointer := B_Pointer (S.Null_A_Pointer);
end;

package S is
   type A_Type is new Integer;
   type A_Pointer is access A_Type;
   Null_A_Pointer : constant A_Pointer := null;
end;

Moreover, it also plugs a loophole in the compiler whereby an
instantiation of a generic with a formal subprogram declaration nested
in an enclosing generic package would be done even if there was a
mismatch between an original and a derived types involved in the
instantiation.

The compiler must now gives the following error:
p.adb:11:43: no visible subprogram matches the specification for "Action"
on

with Q;
with R;
with G;

procedure P is

  package My_G is new G (Q.T);

  procedure Proc (Value : R.T) is null;

  procedure Iter is new My_G.Iteration_G (Proc);

begin
  null;
end;

with R;

package Q is

  type T is new R.T;

end Q;

package R is

  type T is private;

private

  type T is access Integer;

end R;

generic

  type Value_T is private;

package G is

  generic
    with procedure Action (Value : Value_T);
  procedure Iteration_G;

end G;

package body G is

  procedure Iteration_G is null;

end G;

2019-07-22  Eric Botcazou  <ebotcazou@adacore.com>

gcc/ada/

	* sem_ch3.adb (Complete_Private_Subtype): Rework the setting of
	the Etype of the full view for full base types that cannot
	contain any discriminant.  Remove code and comment about it in
	the main path.

From-SVN: r273681

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 2d0beb3841a64c5fcd91526ae3f374df719f57bb..f715f7165b821541094d6e0e74d93c7b758dab8a 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,10 @@
+2019-07-22  Eric Botcazou  <ebotcazou@adacore.com>
+
+       * sem_ch3.adb (Complete_Private_Subtype): Rework the setting of
+       the Etype of the full view for full base types that cannot
+       contain any discriminant.  Remove code and comment about it in
+       the main path.
+
 2019-07-22  Ed Schonberg  <schonberg@adacore.com>
 
        * sem_ch3.adb (Convert_Bound): Subsidiary of

diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 5bee503e885ba103cf8462a01959a7f126536875..a6df5e4636eb1b07ae8c6972d03b01fcbd20523f 100644 (file)
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -12351,48 +12351,73 @@ package body Sem_Ch3 is
       --  Next_Entity field of full to ensure that the calls to Copy_Node do
       --  not corrupt the entity chain.
 
-      --  Note that the type of the full view is the same entity as the type
-      --  of the partial view. In this fashion, the subtype has access to the
-      --  correct view of the parent.
-      --  The list below included access types, but this leads to several
-      --  regressions. How should the base type of the full view be
-      --  set consistently for subtypes completed by access types?
-
       Save_Next_Entity := Next_Entity (Full);
       Save_Homonym     := Homonym (Priv);
 
-      case Ekind (Full_Base) is
-         when Class_Wide_Kind
-            | Private_Kind
-            | Protected_Kind
-            | Task_Kind
-            | E_Record_Subtype
-            | E_Record_Type
-         =>
-            Copy_Node (Priv, Full);
+      if Ekind (Full_Base) in Private_Kind
+        or else Ekind (Full_Base) in Protected_Kind
+        or else Ekind (Full_Base) in Record_Kind
+        or else Ekind (Full_Base) in Task_Kind
+      then
+         Copy_Node (Priv, Full);
 
-            Set_Has_Discriminants
-                             (Full, Has_Discriminants (Full_Base));
-            Set_Has_Unknown_Discriminants
-                             (Full, Has_Unknown_Discriminants (Full_Base));
-            Set_First_Entity (Full, First_Entity (Full_Base));
-            Set_Last_Entity  (Full, Last_Entity (Full_Base));
+         --  Note that the Etype of the full view is the same as the Etype of
+         --  the partial view. In this fashion, the subtype has access to the
+         --  correct view of the parent.
 
-            --  If the underlying base type is constrained, we know that the
-            --  full view of the subtype is constrained as well (the converse
-            --  is not necessarily true).
+         Set_Has_Discriminants (Full, Has_Discriminants (Full_Base));
+         Set_Has_Unknown_Discriminants
+                                 (Full, Has_Unknown_Discriminants (Full_Base));
+         Set_First_Entity (Full, First_Entity (Full_Base));
+         Set_Last_Entity  (Full, Last_Entity (Full_Base));
 
-            if Is_Constrained (Full_Base) then
-               Set_Is_Constrained (Full);
-            end if;
+         --  If the underlying base type is constrained, we know that the
+         --  full view of the subtype is constrained as well (the converse
+         --  is not necessarily true).
 
-         when others =>
-            Copy_Node (Full_Base, Full);
+         if Is_Constrained (Full_Base) then
+            Set_Is_Constrained (Full);
+         end if;
 
-            Set_Chars         (Full, Chars (Priv));
-            Conditional_Delay (Full, Priv);
-            Set_Sloc          (Full, Sloc (Priv));
-      end case;
+      else
+         Copy_Node (Full_Base, Full);
+
+         --  The following subtlety with the Etype of the full view needs to be
+         --  taken into account here. One could think that it must naturally be
+         --  set to the base type of the full base:
+
+         --    Set_Etype (Full, Base_Type (Full_Base));
+
+         --  so that the full view becomes a subtype of the full base when the
+         --  latter is a base type, which must for example happen when the full
+         --  base is declared as derived type. That's also correct if the full
+         --  base is declared as an array type, or a floating-point type, or a
+         --  fixed-point type, or a signed integer type, as these declarations
+         --  create an implicit base type and a first subtype so the Etype of
+         --  the full views must be the implicit base type. But that's wrong
+         --  if the full base is declared as an access type, or an enumeration
+         --  type, or a modular integer type, as these declarations directly
+         --  create a base type, i.e. with Etype pointing to itself. Moreover
+         --  the full base being declared in the private part, i.e. when the
+         --  views are swapped, the end result is that the Etype of the full
+         --  base is set to its private view in this case and that we need to
+         --  propagate this setting to the full view in order for the subtype
+         --  to be compatible with the base type.
+
+         if Is_Base_Type (Full_Base)
+           and then (Is_Derived_Type (Full_Base)
+                      or else Ekind (Full_Base) in Array_Kind
+                      or else Ekind (Full_Base) in Fixed_Point_Kind
+                      or else Ekind (Full_Base) in Float_Kind
+                      or else Ekind (Full_Base) in Signed_Integer_Kind)
+         then
+            Set_Etype (Full, Full_Base);
+         end if;
+
+         Set_Chars         (Full, Chars (Priv));
+         Set_Sloc          (Full, Sloc (Priv));
+         Conditional_Delay (Full, Priv);
+      end if;
 
       Link_Entities                 (Full, Save_Next_Entity);
       Set_Homonym                   (Full, Save_Homonym);
@@ -12400,35 +12425,14 @@ package body Sem_Ch3 is
 
       --  Set common attributes for all subtypes: kind, convention, etc.
 
-      Set_Ekind (Full, Subtype_Kind (Ekind (Full_Base)));
-      Set_Convention (Full, Convention (Full_Base));
-
-      --  The Etype of the full view is inconsistent. Gigi needs to see the
-      --  structural full view, which is what the current scheme gives: the
-      --  Etype of the full view is the etype of the full base. However, if the
-      --  full base is a derived type, the full view then looks like a subtype
-      --  of the parent, not a subtype of the full base. If instead we write:
-
-      --       Set_Etype (Full, Full_Base);
-
-      --  then we get inconsistencies in the front-end (confusion between
-      --  views). Several outstanding bugs are related to this ???
-
+      Set_Ekind            (Full, Subtype_Kind (Ekind (Full_Base)));
+      Set_Convention       (Full, Convention (Full_Base));
       Set_Is_First_Subtype (Full, False);
       Set_Scope            (Full, Scope (Priv));
       Set_Size_Info        (Full, Full_Base);
       Set_RM_Size          (Full, RM_Size (Full_Base));
       Set_Is_Itype         (Full);
 
-      --  For the unusual case of a type with unknown discriminants whose
-      --  completion is an array, use the proper full base.
-
-      if Is_Array_Type (Full_Base)
-        and then Has_Unknown_Discriminants (Priv)
-      then
-         Set_Etype (Full, Full_Base);
-      end if;
-
       --  A subtype of a private-type-without-discriminants, whose full-view
       --  has discriminants with default expressions, is not constrained.