exp_ch5.adb (Get_Default_Iterator): For a derived type...

2017-01-06  Ed Schonberg  <schonberg@adacore.com>

	* exp_ch5.adb (Get_Default_Iterator): For a derived type, the
	alias of the inherited op is the parent iterator, no need to
	examine dispatch table positions which might not be established
	yet if type is not frozen.
	* sem_disp.adb (Check_Controlling_Formals): The formal of a
	predicate function may be a subtype of a tagged type.
	* sem_ch3.adb (Complete_Private_Subtype): Adjust inheritance
	of representation items for the completion of a type extension
	where a predicate applies to the partial view.
	* checks.ads, checks.adb (Apply_Predicate_Check): Add optional
	parameter that designates function whose actual receives a
	predicate check, to improve warning message when the check will
	lead to infinite recursion.
	* sem_res.adb (Resolve_Actuals): Pass additional parameter to
	Apply_Predicate_Check.

From-SVN: r244132

gcc/ada/ChangeLog

@@ -1,3 +1,21 @@
+2017-01-06  Ed Schonberg  <schonberg@adacore.com>
+
+	* exp_ch5.adb (Get_Default_Iterator): For a derived type, the
+	alias of the inherited op is the parent iterator, no need to
+	examine dispatch table positions which might not be established
+	yet if type is not frozen.
+	* sem_disp.adb (Check_Controlling_Formals): The formal of a
+	predicate function may be a subtype of a tagged type.
+	* sem_ch3.adb (Complete_Private_Subtype): Adjust inheritance
+	of representation items for the completion of a type extension
+	where a predicate applies to the partial view.
+	* checks.ads, checks.adb (Apply_Predicate_Check): Add optional
+	parameter that designates function whose actual receives a
+	predicate check, to improve warning message when the check will
+	lead to infinite recursion.
+	* sem_res.adb (Resolve_Actuals): Pass additional parameter to
+	Apply_Predicate_Check.
+
 2017-01-06  Tristan Gingold  <gingold@adacore.com>
 
 	* s-rident.ads (Profile_Info): Remove No_Entry_Queue from

gcc/ada/checks.adb

@@ -2605,7 +2605,11 @@ package body Checks is
    -- Apply_Predicate_Check --
    ---------------------------
 
-   procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
+   procedure Apply_Predicate_Check
+     (N   : Node_Id;
+      Typ : Entity_Id;
+      Fun : Entity_Id := Empty)
+   is
       S : Entity_Id;
 
    begin
@@ -2633,11 +2637,18 @@ package body Checks is
          --  is likely to be a common error, and thus deserves a warning.
 
          elsif Present (S) and then S = Predicate_Function (Typ) then
-            Error_Msg_N
+            Error_Msg_NE
-              ("predicate check includes a function call that "
+              ("predicate check includes a call to& that "
-               & "requires a predicate check??", Parent (N));
+               & "requires a predicate check??", Parent (N), Fun);
             Error_Msg_N
               ("\this will result in infinite recursion??", Parent (N));
+
+            if Is_First_Subtype (Typ) then
+               Error_Msg_NE
+               ("\use an explicit subtype of& to carry the predicate",
+                  Parent (N), Typ);
+            end if;
+
             Insert_Action (N,
               Make_Raise_Storage_Error (Sloc (N),
                 Reason => SE_Infinite_Recursion));

gcc/ada/checks.ads

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -255,9 +255,14 @@ package Checks is
    --  verify the proper initialization of scalars in parameters and function
    --  results.
 
-   procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id);
+   procedure Apply_Predicate_Check
-   --  N is an expression to which a predicate check may need to be applied
+     (N   : Node_Id;
-   --  for Typ, if Typ has a predicate function.
+      Typ : Entity_Id;
+      Fun : Entity_Id := Empty);
+   --  N is an expression to which a predicate check may need to be applied for
+   --  Typ, if Typ has a predicate function. When N is an actual in a call, Fun
+   --  is the function being called, which is used to generate a better warning
+   --  if the call leads to an infinite recursion.
 
    procedure Apply_Type_Conversion_Checks (N : Node_Id);
    --  N is an N_Type_Conversion node. A type conversion actually involves

gcc/ada/exp_ch5.adb

@@ -3769,14 +3769,17 @@ package body Exp_Ch5 is
                elsif Is_Derived_Type (T) then
 
                   --  The default iterator must be a primitive operation of the
-                  --  type, at the same dispatch slot position.
+                  --  type, at the same dispatch slot position. The DT position
+                  --  may not be established if type is not frozen yet.
 
                   Prim := First_Elmt (Primitive_Operations (T));
                   while Present (Prim) loop
                      Op := Node (Prim);
 
-                     if Chars (Op) = Chars (Iter)
+                     if Alias (Op) = Iter
-                       and then DT_Position (Op) = DT_Position (Iter)
+                       or else (Chars (Op) = Chars (Iter)
+                         and then Present (DTC_Entity (Op))
+                         and then DT_Position (Op) = DT_Position (Iter))
                      then
                         return Op;
                      end if;

gcc/ada/sem_ch3.adb

@@ -11947,9 +11947,11 @@ package body Sem_Ch3 is
          Append    : Boolean;
          Item      : Node_Id;
          Next_Item : Node_Id;
+         Priv_Item : Node_Id;
 
       begin
          Item := First_Rep_Item (Full);
+         Priv_Item := First_Rep_Item (Priv);
 
          --  If no existing rep items on full type, we can just link directly
          --  to the list of items on the private type, if any exist.. Same if
@@ -11960,14 +11962,24 @@ package body Sem_Ch3 is
               or else Entity (Item) = Full_Base)
              and then Present (First_Rep_Item (Priv))
          then
-            Set_First_Rep_Item (Full, First_Rep_Item (Priv));
+            Set_First_Rep_Item (Full, Priv_Item);
 
          --  Otherwise, search to the end of items currently linked to the full
          --  subtype and append the private items to the end. However, if Priv
          --  and Full already have the same list of rep items, then the append
          --  is not done, as that would create a circularity.
+         --
+         --  The partial view may have a predicate and the rep item lists of
+         --  both views agree when inherited from the same ancestor. In that
+         --  case, simply propagate the list from one view to the other.
+         --  A more complex analysis needed here ???
 
-         elsif Item /= First_Rep_Item (Priv) then
+         elsif Present (Priv_Item)
+           and then Item = Next_Rep_Item (Priv_Item)
+         then
+            Set_First_Rep_Item (Full, Priv_Item);
+
+         elsif Item /= Priv_Item then
             Append := True;
             loop
                Next_Item := Next_Rep_Item (Item);

gcc/ada/sem_disp.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2015, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2016, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -234,7 +234,13 @@ package body Sem_Disp is
                         Formal);
                   end if;
 
-               elsif not Subtypes_Statically_Match (Typ, Etype (Formal)) then
+               --  Within a predicate function, the formal may be a subtype
+               --  of a tagged type, given that the predicate is expressed
+               --  in terms of the subtype.
+
+               elsif not Subtypes_Statically_Match (Typ, Etype (Formal))
+                 and then not Is_Predicate_Function (Subp)
+               then
                   Error_Msg_N
                     ("parameter subtype does not match controlling type",
                      Formal);

gcc/ada/sem_res.adb

@@ -4265,10 +4265,12 @@ package body Sem_Res is
                --  Apply predicate tests except in certain special cases. Note
                --  that it might be more consistent to apply these only when
                --  expansion is active (in Exp_Ch6.Expand_Actuals), as we do
-               --  for the outbound predicate tests ???
+               --  for the outbound predicate tests ??? In any case indicate
+               --  the function being called, for better warnings if the call
+               --  leads to an infinite recursion.
 
                if Predicate_Tests_On_Arguments (Nam) then
-                  Apply_Predicate_Check (A, F_Typ);
+                  Apply_Predicate_Check (A, F_Typ, Nam);
                end if;
 
                --  Apply required constraint checks