[Ada] Spurious error on instantiation with type with unknown discriminants

This patch fixes a spurious error when instantiating an indefinite container
with a private type with unknown discriminants, when its full view is an
unconstrained array type. It also cleans up the inheritance of dynamic
predicates inherited by anonymous subtypes of array types.

2018-05-23  Ed Schonberg  <schonberg@adacore.com>

gcc/ada/

	* einfo.ads: New attribute on types: Predicated_Parent, to simplify the
	retrieval of the applicable predicate function to an itype created for
	a constrained array component.
	* einfo.adb: Subprograms for Predicated_Parent.
	(Predicate_Function): Use new attribute.
	* exp_util.adb (Make_Predicate_Call): If the predicate function is not
	available for a subtype, retrieve it from the base type, which may have
	been frozen after the subtype declaration and not captured by the
	subtype declaration.
	* sem_aggr.adb (Resolve_Array_Aggregate): An Others association is
	legal within a generated initiqlization procedure, as may happen with a
	predicate check on a component, when the predicate function applies to
	the base type of the component.
	* sem_ch3.adb (Analyze_Subtype_Declaration): Clean up inheritance of
	predicates for subtype declarations and for subtype indications in
	other contexts.
	(Process_Subtype): Likewise. Handle properly the case of a private type
	with unknown discriminants whose full view is an unconstrained array.
	Use Predicated_Parent to indicate source of predicate function on an
	itype whose parent is itself an itype.
	(Complete_Private_Subtype): If the private view has unknown
	discriminants and the full view is an unconstrained array, set base
	type of completion to the full view of parent.
	(Inherit_Predicate_Flags): Prevent double assignment of predicate
	function and flags.
	(Build_Subtype): For a constrained array component, propagate predicate
	information from original component type declaration.

gcc/testsuite/

	* gnat.dg/discr51.adb: New testcase.

From-SVN: r260596

gcc/ada/ChangeLog

+2018-05-23  Ed Schonberg  <schonberg@adacore.com>
+
+	* einfo.ads: New attribute on types: Predicated_Parent, to simplify the
+	retrieval of the applicable predicate function to an itype created for
+	a constrained array component.
+	* einfo.adb: Subprograms for Predicated_Parent.
+	(Predicate_Function): Use new attribute.
+	* exp_util.adb (Make_Predicate_Call): If the predicate function is not
+	available for a subtype, retrieve it from the base type, which may have
+	been frozen after the subtype declaration and not captured by the
+	subtype declaration.
+	* sem_aggr.adb (Resolve_Array_Aggregate): An Others association is
+	legal within a generated initiqlization procedure, as may happen with a
+	predicate check on a component, when the predicate function applies to
+	the base type of the component.
+	* sem_ch3.adb (Analyze_Subtype_Declaration): Clean up inheritance of
+	predicates for subtype declarations and for subtype indications in
+	other contexts.
+	(Process_Subtype): Likewise. Handle properly the case of a private type
+	with unknown discriminants whose full view is an unconstrained array.
+	Use Predicated_Parent to indicate source of predicate function on an
+	itype whose parent is itself an itype.
+	(Complete_Private_Subtype): If the private view has unknown
+	discriminants and the full view is an unconstrained array, set base
+	type of completion to the full view of parent.
+	(Inherit_Predicate_Flags): Prevent double assignment of predicate
+	function and flags.
+	(Build_Subtype): For a constrained array component, propagate predicate
+	information from original component type declaration.
+
 2018-05-23  Boris Yakobowski  <yakobowski@adacore.com>
 
 	* libgnat/a-ngelfu.ads (Arctanh, Arccoth): Fix faulty preconditions.

gcc/ada/einfo.adb

@@ -276,6 +276,7 @@ package body Einfo is
 
    --    Nested_Scenarios                Elist36
    --    Validated_Object                Node36
+   --    Predicated_Parent               Node36
 
    --    Class_Wide_Clone                Node38
 
@@ -3082,6 +3083,12 @@ package body Einfo is
       return Node14 (Id);
    end Postconditions_Proc;
 
+   function Predicated_Parent (Id : E) return E is
+   begin
+      pragma Assert (Is_Type (Id));
+      return Node36 (Id);
+   end Predicated_Parent;
+
    function Predicates_Ignored (Id : E) return B is
    begin
       pragma Assert (Is_Type (Id));
@@ -6311,6 +6318,12 @@ package body Einfo is
       Set_Node14 (Id, V);
    end Set_Postconditions_Proc;
 
+   procedure Set_Predicated_Parent (Id : E; V : E) is
+   begin
+      pragma Assert (Is_Type (Id));
+      Set_Node36 (Id, V);
+   end Set_Predicated_Parent;
+
    procedure Set_Predicates_Ignored (Id : E; V : B) is
    begin
       pragma Assert (Is_Type (Id));
@@ -8829,6 +8842,9 @@ package body Einfo is
       then
          Typ := Full_View (Id);
 
+      elsif Is_Itype (Id) and then Present (Predicated_Parent (Id)) then
+         Typ := Predicated_Parent (Id);
+
       else
          Typ := Id;
       end if;
@@ -11200,6 +11216,11 @@ package body Einfo is
          when E_Variable =>
             Write_Str ("Validated_Object");
 
+         when E_Array_Subtype
+            | E_Record_Subtype
+         =>
+            Write_Str ("predicated parent");
+
          when others =>
             Write_Str ("Field36??");
       end case;

gcc/ada/einfo.ads

@@ -3932,6 +3932,14 @@ package Einfo is
 --       is the special version created for membership tests, where if one of
 --       these raise expressions is executed, the result is to return False.
 
+--    Predicated_Parent (Node36)
+--       Defined on itypes created by subtype indications, when the parent
+--       subtype has predicates. The itype shares the Predicate_Function
+--       of the predicated parent, but this function may not have been built
+--       at the point the Itype is constructed, so this attribute allows its
+--       retrieval at the point a predicate check needs to be generated.
+--       The utility Predicate_Function takes this link into account.
+
 --    Predicates_Ignored (Flag288)
 --       Defined on all types. Indicates whether the subtype declaration is in
 --       a context where Assertion_Policy is Ignore, in which case no checks
@@ -7427,6 +7435,7 @@ package Einfo is
    function Partial_View_Has_Unknown_Discr      (Id : E) return B;
    function Pending_Access_Types                (Id : E) return L;
    function Postconditions_Proc                 (Id : E) return E;
+   function Predicated_Parent                   (Id : E) return E;
    function Predicates_Ignored                  (Id : E) return B;
    function Prival                              (Id : E) return E;
    function Prival_Link                         (Id : E) return E;
@@ -7789,6 +7798,7 @@ package Einfo is
    procedure Set_Depends_On_Private              (Id : E; V : B := True);
    procedure Set_Derived_Type_Link               (Id : E; V : E);
    procedure Set_Digits_Value                    (Id : E; V : U);
+   procedure Set_Predicated_Parent               (Id : E; V : E);
    procedure Set_Predicates_Ignored              (Id : E; V : B);
    procedure Set_Direct_Primitive_Operations     (Id : E; V : L);
    procedure Set_Directly_Designated_Type        (Id : E; V : E);
@@ -8988,6 +8998,7 @@ package Einfo is
    pragma Inline (Partial_View_Has_Unknown_Discr);
    pragma Inline (Pending_Access_Types);
    pragma Inline (Postconditions_Proc);
+   pragma Inline (Predicated_Parent);
    pragma Inline (Predicates_Ignored);
    pragma Inline (Prival);
    pragma Inline (Prival_Link);
@@ -9475,6 +9486,7 @@ package Einfo is
    pragma Inline (Set_Partial_View_Has_Unknown_Discr);
    pragma Inline (Set_Pending_Access_Types);
    pragma Inline (Set_Postconditions_Proc);
+   pragma Inline (Set_Predicated_Parent);
    pragma Inline (Set_Predicates_Ignored);
    pragma Inline (Set_Prival);
    pragma Inline (Set_Prival_Link);

gcc/ada/exp_util.adb

@@ -9261,7 +9261,8 @@ package body Exp_Util is
       Func_Id : Entity_Id;
 
    begin
-      pragma Assert (Present (Predicate_Function (Typ)));
+      Func_Id := Predicate_Function (Typ);
+      pragma Assert (Present (Func_Id));
 
       --  The related type may be subject to pragma Ghost. Set the mode now to
       --  ensure that the call is properly marked as Ghost.
@@ -9272,8 +9273,6 @@ package body Exp_Util is
 
       if Mem and then Present (Predicate_Function_M (Typ)) then
          Func_Id := Predicate_Function_M (Typ);
-      else
-         Func_Id := Predicate_Function (Typ);
       end if;
 
       --  Case of calling normal predicate function

gcc/ada/sem_aggr.adb

@@ -1068,7 +1068,9 @@ package body Sem_Aggr is
             --  object may be its unconstrained nominal type. However, if the
             --  context is an assignment, we assume that OTHERS is allowed,
             --  because the target of the assignment will have a constrained
-            --  subtype when fully compiled.
+            --  subtype when fully compiled. Ditto if the context is an
+            --  initialization procedure where a component may have a predicate
+            --  function that carries the base type.
 
             --  Note that there is no node for Explicit_Actual_Parameter.
             --  To test for this context we therefore have to test for node
@@ -1083,6 +1085,7 @@ package body Sem_Aggr is
             Set_Etype (N, Aggr_Typ);  --  May be overridden later on
 
             if Pkind = N_Assignment_Statement
+              or else Inside_Init_Proc
               or else (Is_Constrained (Typ)
                         and then
                           (Pkind = N_Parameter_Association     or else

gcc/ada/sem_ch3.adb

@@ -5338,11 +5338,13 @@ package body Sem_Ch3 is
          if not Comes_From_Source (N) then
             Set_Ekind (Id, Ekind (T));
 
-            if Present (Predicate_Function (T)) then
+            if Present (Predicate_Function (Id)) then
+               null;
+
+            elsif Present (Predicate_Function (T)) then
                Set_Predicate_Function (Id, Predicate_Function (T));
 
             elsif Present (Ancestor_Subtype (T))
-              and then Has_Predicates (Ancestor_Subtype (T))
               and then Present (Predicate_Function (Ancestor_Subtype (T)))
             then
                Set_Predicate_Function (Id,
@@ -5443,7 +5445,6 @@ package body Sem_Ch3 is
                Set_Is_Constrained       (Id, Is_Constrained     (T));
                Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
                Set_RM_Size              (Id, RM_Size            (T));
-               Inherit_Predicate_Flags  (Id, T);
 
             when Ordinary_Fixed_Point_Kind =>
                Set_Ekind                (Id, E_Ordinary_Fixed_Point_Subtype);
@@ -5469,7 +5470,6 @@ package body Sem_Ch3 is
                Set_Is_Constrained       (Id, Is_Constrained     (T));
                Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
                Set_RM_Size              (Id, RM_Size            (T));
-               Inherit_Predicate_Flags  (Id, T);
 
             when Modular_Integer_Kind =>
                Set_Ekind                (Id, E_Modular_Integer_Subtype);
@@ -5477,7 +5477,6 @@ package body Sem_Ch3 is
                Set_Is_Constrained       (Id, Is_Constrained     (T));
                Set_Is_Known_Valid       (Id, Is_Known_Valid     (T));
                Set_RM_Size              (Id, RM_Size            (T));
-               Inherit_Predicate_Flags  (Id, T);
 
             when Class_Wide_Kind =>
                Set_Ekind                (Id, E_Class_Wide_Subtype);
@@ -5694,6 +5693,11 @@ package body Sem_Ch3 is
             when others =>
                raise Program_Error;
          end case;
+
+         --  If there is no constraint in the subtype indication, the
+         --  declared entity inherits predicates from the parent.
+
+         Inherit_Predicate_Flags (Id, T);
       end if;
 
       if Etype (Id) = Any_Type then
@@ -12345,6 +12349,15 @@ package body Sem_Ch3 is
       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.
 
@@ -13427,6 +13440,27 @@ package body Sem_Ch3 is
 
          Analyze (Subtyp_Decl, Suppress => All_Checks);
 
+         if Is_Itype (Def_Id) and then Has_Predicates (T) then
+            Inherit_Predicate_Flags (Def_Id, T);
+
+            --  Indicate where the predicate function may be found.
+
+            if Is_Itype (T) then
+               if Present (Predicate_Function (Def_Id)) then
+                  null;
+
+               elsif Present (Predicate_Function (T)) then
+                  Set_Predicate_Function (Def_Id, Predicate_Function (T));
+
+               else
+                  Set_Predicated_Parent (Def_Id, Predicated_Parent (T));
+               end if;
+
+            elsif No (Predicate_Function (Def_Id)) then
+               Set_Predicated_Parent (Def_Id, T);
+            end if;
+         end if;
+
          return Def_Id;
       end Build_Subtype;
 
@@ -18550,6 +18584,10 @@ package body Sem_Ch3 is
 
    procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
    begin
+      if Present (Predicate_Function (Subt)) then
+         return;
+      end if;
+
       Set_Has_Predicates (Subt, Has_Predicates (Par));
       Set_Has_Static_Predicate_Aspect
         (Subt, Has_Static_Predicate_Aspect (Par));
@@ -21606,7 +21644,6 @@ package body Sem_Ch3 is
 
             when Enumeration_Kind =>
                Constrain_Enumeration (Def_Id, S);
-               Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
 
             when Ordinary_Fixed_Point_Kind =>
                Constrain_Ordinary_Fixed (Def_Id, S);
@@ -21616,7 +21653,6 @@ package body Sem_Ch3 is
 
             when Integer_Kind =>
                Constrain_Integer (Def_Id, S);
-               Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
 
             when Class_Wide_Kind
                | E_Incomplete_Type
@@ -21630,7 +21666,21 @@ package body Sem_Ch3 is
                end if;
 
             when Private_Kind =>
-               Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+
+               --  A private type with unknown discriminants may be completed
+               --  by an unconstrained array type.
+
+               if Has_Unknown_Discriminants (Subtype_Mark_Id)
+                 and then Present (Full_View (Subtype_Mark_Id))
+                 and then Is_Array_Type (Full_View (Subtype_Mark_Id))
+               then
+                  Constrain_Array (Def_Id, S, Related_Nod, Related_Id, Suffix);
+
+                  --  ... but more comonly by a discriminated record type.
+
+               else
+                  Constrain_Discriminated_Type (Def_Id, S, Related_Nod);
+               end if;
 
                --  The base type may be private but Def_Id may be a full view
                --  in an instance.
@@ -21696,6 +21746,19 @@ package body Sem_Ch3 is
          Set_Rep_Info   (Def_Id,            (Subtype_Mark_Id));
          Set_Convention (Def_Id, Convention (Subtype_Mark_Id));
 
+         --  The anonymous subtype created for the subtype indication
+         --  inherits the predicates of the parent.
+
+         if Has_Predicates (Subtype_Mark_Id) then
+            Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
+
+            --  Indicate where the predicate function may be found.
+
+            if No (Predicate_Function (Def_Id)) then
+               Set_Predicated_Parent (Def_Id, Subtype_Mark_Id);
+            end if;
+         end if;
+
          return Def_Id;
       end if;
    end Process_Subtype;

gcc/testsuite/ChangeLog

+2018-05-23  Ed Schonberg  <schonberg@adacore.com>
+
+	* gnat.dg/discr51.adb: New testcase.
+
 2018-05-23  Javier Miranda  <miranda@adacore.com>
 
 	* gnat.dg/valid_scalars1.adb: New testcase.

gcc/testsuite/gnat.dg/discr51.adb

+--  { dg-do compile }
+
+with Ada.Containers.Indefinite_Holders;
+
+procedure Discr51 is
+
+   package Inner is
+      type Str (<>) is private;
+   private
+      type Str is array (Positive range <>) of Character;
+   end Inner;
+
+   package Inner2 is
+      type Str2 (<>) is private;
+   private
+      type str2 is new inner.Str;
+   end Inner2;
+
+   type Str3 is new Inner.str;
+
+   package Str_Holders is new Ada.Containers.Indefinite_Holders
+      (Inner.Str, Inner."=");
+
+   package Str2_Holders is new Ada.Containers.Indefinite_Holders
+      (Inner2.Str2, Inner2."=");
+
+   package Str3_Holders is new Ada.Containers.Indefinite_Holders
+      (Str3, "=");
+
+begin
+   null;
+end Discr51;