ada: Fix Itype-related predicate check omissions.

Clean up problematic interactions between Itype subtypes and predicates,
which were causing required predicate checks to be (incorrectly) omitted.

gcc/ada/ChangeLog:

	* einfo-utils.adb (Predicate_Function): Improve handling of a case
	where a predicate specified for a subtype of a partial view of a
	type was incorrectly ignored.
	(Set_Predicate_Function): If the attribute has already been set to
	the same value, then do nothing (instead of raising P_E).
	* sem_ch13.adb (Build_Predicate_Function): Add new function
	Has_Source_Predicate. If a subtype inherits a predicate but also
	has its own explicitly specified predicate, then avoid
	misinterpreting the presence of the function built for the
	inherited predicate to mean that no additional predicate function
	is needed.
	* sem_util.adb (Build_Subtype): In the case where we are given a
	constrained record or array subtype and we need to construct a
	different subtype, subject to a different constraint, the
	subtype_mark of the constructed subtype needs to reference an
	unconstrained subtype (because a new constraint is going to be
	imposed). If the Predicated_Parent attribute of the given subtype
	is present and refers to a suitable unconstrained subtype, then
	use that subtype instead of setting the Predicated_Parent
	attribute on a new node (and performing the associated attribute
	copying).

diff --git a/gcc/ada/einfo-utils.adb b/gcc/ada/einfo-utils.adb
index 91d273cb32d9d2d25e6af0530f81458e7fe803c2..60ee509da674a231c5647046488012e801825a57 100644 (file)
--- a/gcc/ada/einfo-utils.adb
+++ b/gcc/ada/einfo-utils.adb
@@ -2376,6 +2376,37 @@ package body Einfo.Utils is
             if Ekind (Subp_Id) = E_Function
               and then Is_Predicate_Function (Subp_Id)
             then
+               --  We may have incorrectly looked through predicate-bearing
+               --  subtypes when going from a private subtype to its full
+               --  view, so compensate for that case. Unfortunately,
+               --  Subp_Id might not be analyzed at this point, so we
+               --  use a crude works-most-of-the-time text-based
+               --  test to detect the case where Id is a subtype (declared by
+               --  a subtype declaration) and no predicate was explicitly
+               --  specified for Id. Ugh. ???
+
+               if Nkind (Parent (Id)) = N_Subtype_Declaration
+                 -- 1st choice ...
+                 --   and then Etype (First_Entity (Subp_Id)) /= Id
+                 -- but that doesn't work if Subp_Id is not analyzed.
+
+                 --  so we settle for 2nd choice, ignoring cases like
+                 --  "subtype Foo is Pkg.Foo;" where distinct subtypes
+                 --  have the same identifier:
+                 --
+                 and then Get_Name_String (Chars (Subp_Id)) /=
+                          Get_Name_String (Chars (Id)) & "Predicate"
+               then
+                  declare
+                     Mark : Node_Id := Subtype_Indication (Parent (Id));
+                  begin
+                     if Nkind (Mark) = N_Subtype_Indication then
+                        Mark := Subtype_Mark (Mark);
+                     end if;
+                     return Predicate_Function (Entity (Mark));
+                  end;
+               end if;
+
                return Subp_Id;
             end if;
 
@@ -2803,7 +2834,6 @@ package body Einfo.Utils is
       end if;
 
       Subp_Elmt := First_Elmt (Subps);
-      Prepend_Elmt (V, Subps);
 
       --  Check for a duplicate predication function
 
@@ -2813,11 +2843,17 @@ package body Einfo.Utils is
          if Ekind (Subp_Id) = E_Function
            and then Is_Predicate_Function (Subp_Id)
          then
-            raise Program_Error;
+            if V = Subp_Id then
+               return;
+            else
+               raise Program_Error;
+            end if;
          end if;
 
          Next_Elmt (Subp_Elmt);
       end loop;
+
+      Prepend_Elmt (V, Subps);
    end Set_Predicate_Function;
 
    -----------------

diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 22575f9cbf5fe28fafc549ab231ed1db5a8294e4..dcca3fc57aab561b93729b8ac67ff669b25f10b9 100644 (file)
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -9986,6 +9986,12 @@ package body Sem_Ch13 is
       --  Includes a call to the predicate function for type T in Expr if
       --  Predicate_Function (T) is non-empty.
 
+      function Has_Source_Predicate (T : Entity_Id) return Boolean;
+      --  Return True if one of the 3 predicate aspects is specified
+      --  explicitly (either via a pragma or an aspect specification, but
+      --  not implicitly via propagation from some other type/subtype via
+      --  RM 3.2.4(5)) for the type/subtype T.
+
       procedure Replace_Current_Instance_References
         (N : Node_Id; Typ, New_Entity : Entity_Id);
       --  Replace all references to Typ in the tree rooted at N with
@@ -10202,6 +10208,41 @@ package body Sem_Ch13 is
          end loop;
       end Add_Predicates;
 
+      --------------------------
+      -- Has_Source_Predicate --
+      --------------------------
+
+      function Has_Source_Predicate (T : Entity_Id) return Boolean is
+         Rep_Item : Node_Id := First_Rep_Item (T);
+      begin
+         while Present (Rep_Item) loop
+            case Nkind (Rep_Item) is
+               when N_Pragma =>
+                  if Get_Pragma_Id (Rep_Item) = Pragma_Predicate
+                    and then T = Entity (Expression
+                      (First (Pragma_Argument_Associations (Rep_Item))))
+                  then
+                     return True;
+                  end if;
+
+               when N_Aspect_Specification =>
+                  if Get_Aspect_Id (Rep_Item) in
+                       Aspect_Static_Predicate
+                         | Aspect_Dynamic_Predicate | Aspect_Predicate
+                    and then Entity (Rep_Item) = T
+                  then
+                     return True;
+                  end if;
+
+               when others =>
+                  null;
+            end case;
+
+            Next_Rep_Item (Rep_Item);
+         end loop;
+         return False;
+      end Has_Source_Predicate;
+
       -----------------------------------------
       -- Replace_Current_Instance_References --
       -----------------------------------------
@@ -10245,6 +10286,21 @@ package body Sem_Ch13 is
       --  context where expansion and tests are enabled.
 
       SId := Predicate_Function (Typ);
+
+      --  When declaring a subtype S whose "predecessor" subtype PS (that is,
+      --  the subtype denoted by the subtype_mark in the declaration of S)
+      --  already has a predicate function, do not confuse that existing
+      --  function for PS with the function we need to build for S if
+      --  Has_Source_Predicate returns True for S.
+
+      if Present (SId)
+        and then Nkind (Parent (Typ)) = N_Subtype_Declaration
+        and then Etype (First_Entity (SId)) /= Typ
+        and then Has_Source_Predicate (Typ)
+      then
+         SId := Empty;
+      end if;
+
       if not Has_Predicates (Typ)
         or else (Present (SId) and then Has_Completion (SId))
         or else

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 679d0eee21be6b9eda2de3af7b2ae3d410cf0193..c8e30f3dc7ffac9f4023f55d70401df1a7e50295 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -2176,6 +2176,7 @@ package body Sem_Util is
       Def_Id      : Entity_Id;
       Btyp        : Entity_Id := Base_Type (Typ);
 
+      Predicated_Parent_Used : Boolean := False;
    begin
       --  The Related_Node better be here or else we won't be able to
       --  attach new itypes to a node in the tree.
@@ -2190,6 +2191,25 @@ package body Sem_Util is
         and then Present (Underlying_Type (Btyp))
       then
          Btyp := Underlying_Type (Btyp);
+
+      --  If a predicate has been specified for an unconstrained
+      --  ancestor subtype, then that ancestor subtype needs to also
+      --  be an ancestor subtype for the subtype we are building so that
+      --  we don't lose the predicate. It is somewhat ugly here to have
+      --  to replicate the precondition for Predicated_Parent.
+
+      elsif Typ in E_Array_Subtype_Id
+                   | E_Record_Subtype_Id
+                   | E_Record_Subtype_With_Private_Id
+        and then Present (Predicated_Parent (Typ))
+      then
+         --  Assert that the following assignment is only changing the
+         --  subtype, not the type.
+
+         pragma Assert (Base_Type (Predicated_Parent (Typ)) = Btyp);
+
+         Btyp := Predicated_Parent (Typ);
+         Predicated_Parent_Used := True;
       end if;
 
       Indic :=
@@ -2211,7 +2231,10 @@ package body Sem_Util is
 
       Analyze (Subtyp_Decl, Suppress => All_Checks);
 
-      if Is_Itype (Def_Id) and then Has_Predicates (Typ) then
+      if Is_Itype (Def_Id)
+        and then Has_Predicates (Typ)
+        and then not Predicated_Parent_Used
+      then
          Inherit_Predicate_Flags (Def_Id, Typ);
 
          --  Indicate where the predicate function may be found