2014-08-01 Ed Schonberg <schonberg@adacore.com>

	* einfo.ads, einfo.adb New flags No_Predicate_On_Actual and
	No_Dynamic_Predicate_On_Actual, to enforce the generic contract
	on generic units that contain constructs that forbid subtypes
	with predicates.
	* sem_ch3.adb (Analyze_Subtype_Declaration, Process_Subtype):
	Inherit flags indicating the presence of predicates in subtype
	declarations with and without constraints.
	(Inherit_Predicate_Flags): Utility for the above.
	* sem_util.adb (Bad_Predicated_Subtype_Use): In a generic context,
	indicate that the actual cannot have predicates, and preserve
	warning. In an instance, report error if actual has predicates
	and the construct appears in a package declaration.
	* sem_ch12.adb (Diagnose_Predicated_Actual): Report error
	for an actual with predicates, if the corresponding formal
	carries No_Predicate_On_Actual or (in the case of a loop)
	No_Dynamic_Predicate_On_Actual.
	* sem_ch13.adb (Build_Predicate_Functions); Do not build a
	Static_Predicate function if the type is non-static (in the
	presence of previous errors),
	* sem_ch5.adb (Analyze_Loop_Parameter_Specification): Set flag
	No_Dynamic_Predicate_On_Actual in a generic context, to enforce
	generic contract on actuals that cannot have predicates.

From-SVN: r213418

8 files changed, 189 insertions, 15 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 844cdd9..1c81d98 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,28 @@
+2014-08-01  Ed Schonberg  <schonberg@adacore.com>
+
+	* einfo.ads, einfo.adb New flags No_Predicate_On_Actual and
+	No_Dynamic_Predicate_On_Actual, to enforce the generic contract
+	on generic units that contain constructs that forbid subtypes
+	with predicates.
+	* sem_ch3.adb (Analyze_Subtype_Declaration, Process_Subtype):
+	Inherit flags indicating the presence of predicates in subtype
+	declarations with and without constraints.
+	(Inherit_Predicate_Flags): Utility for the above.
+	* sem_util.adb (Bad_Predicated_Subtype_Use): In a generic context,
+	indicate that the actual cannot have predicates, and preserve
+	warning. In an instance, report error if actual has predicates
+	and the construct appears in a package declaration.
+	* sem_ch12.adb (Diagnose_Predicated_Actual): Report error
+	for an actual with predicates, if the corresponding formal
+	carries No_Predicate_On_Actual or (in the case of a loop)
+	No_Dynamic_Predicate_On_Actual.
+	* sem_ch13.adb (Build_Predicate_Functions); Do not build a
+	Static_Predicate function if the type is non-static (in the
+	presence of previous errors),
+	* sem_ch5.adb (Analyze_Loop_Parameter_Specification): Set flag
+	No_Dynamic_Predicate_On_Actual in a generic context, to enforce
+	generic contract on actuals that cannot have predicates.
+
 2014-08-01  Pascal Obry  <obry@adacore.com>
 
 	* a-direct.adb (C_Size): Returns an int64.
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index 92fdff6..0c229a7 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -567,15 +567,12 @@ package body Einfo is
    --    (SSO_Set_Low_By_Default)        Flag273
 
    --    Is_Generic_Actual_Subprogram    Flag274
+   --    No_Predicate_On_Actual          Flag275
+   --    No_Dynamic_Predicate_On_Actual  Flag276
 
    --    (unused)                        Flag2
    --    (unused)                        Flag3
 
-   --    (unused)                        Flag132
-   --    (unused)                        Flag133
-
-   --    (unused)                        Flag275
-   --    (unused)                        Flag276
    --    (unused)                        Flag277
    --    (unused)                        Flag278
    --    (unused)                        Flag279
@@ -2557,12 +2554,24 @@ package body Einfo is
       return Node12 (Id);
    end Next_Inlined_Subprogram;
 
+   function No_Dynamic_Predicate_On_Actual (Id : E) return Boolean is
+   begin
+      pragma Assert (Is_Discrete_Type (Id));
+      return Flag276 (Id);
+   end No_Dynamic_Predicate_On_Actual;
+
    function No_Pool_Assigned (Id : E) return B is
    begin
       pragma Assert (Is_Access_Type (Id));
       return Flag131 (Root_Type (Id));
    end No_Pool_Assigned;
 
+   function No_Predicate_On_Actual (Id : E) return Boolean is
+   begin
+      pragma Assert (Is_Discrete_Type (Id));
+      return Flag275 (Id);
+   end No_Predicate_On_Actual;
+
    function No_Return (Id : E) return B is
    begin
       return Flag113 (Id);
@@ -5344,12 +5353,24 @@ package body Einfo is
       Set_Node12 (Id, V);
    end Set_Next_Inlined_Subprogram;
 
+   procedure Set_No_Dynamic_Predicate_On_Actual (Id : E; V : B := True) is
+   begin
+      pragma Assert (Is_Discrete_Type (Id));
+      Set_Flag276 (Id, V);
+   end Set_No_Dynamic_Predicate_On_Actual;
+
    procedure Set_No_Pool_Assigned (Id : E; V : B := True) is
    begin
       pragma Assert (Is_Access_Type (Id) and then Is_Base_Type (Id));
       Set_Flag131 (Id, V);
    end Set_No_Pool_Assigned;
 
+   procedure Set_No_Predicate_On_Actual (Id : E; V : B := True) is
+   begin
+      pragma Assert (Is_Discrete_Type (Id));
+      Set_Flag275 (Id, V);
+   end Set_No_Predicate_On_Actual;
+
    procedure Set_No_Return (Id : E; V : B := True) is
    begin
       pragma Assert
@@ -8435,7 +8456,9 @@ package body Einfo is
       W ("Needs_Debug_Info",                Flag147 (Id));
       W ("Needs_No_Actuals",                Flag22  (Id));
       W ("Never_Set_In_Source",             Flag115 (Id));
+      W ("No_Dynamic_Predicate_On_actual",  Flag276 (Id));
       W ("No_Pool_Assigned",                Flag131 (Id));
+      W ("No_Predicate_On_actual",          Flag275 (Id));
       W ("No_Return",                       Flag113 (Id));
       W ("No_Strict_Aliasing",              Flag136 (Id));
       W ("Non_Binary_Modulus",              Flag58  (Id));
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 7bb4d9c..c8dd25b 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3347,6 +3347,10 @@ package Einfo is
 --       interpreted as true. Currently this is set for derived Boolean
 --       types which have a convention of C, C++ or Fortran.
 
+--    No_Dynamic_Predicate_On_Actual (Flag276)
+--       Defined on generic formal types that are used in loops and quantified
+--       expressions. The corresponing actual cannot have dynamic predicates.
+
 --    No_Pool_Assigned (Flag131) [root type only]
 --       Defined in access types. Set if a storage size clause applies to the
 --       variable with a static expression value of zero. This flag is used to
@@ -3354,6 +3358,10 @@ package Einfo is
 --       of such an access type. This is set only in the root type, since
 --       derived types must have the same pool.
 
+--    No_Predicate_On_Actual (Flag275)
+--       Defined on generic formal types that are used in the spec of a generic
+--       package, in constructs that forbid discrete types with predicates.
+
 --    No_Return (Flag113)
 --       Defined in all entities. Always false except in the case of procedures
 --       and generic procedures for which a pragma No_Return is given.
@@ -5566,6 +5574,8 @@ package Einfo is
    --    Has_Enumeration_Rep_Clause          (Flag66)
    --    Has_Pragma_Ordered                  (Flag198)  (base type only)
    --    Nonzero_Is_True                     (Flag162)  (base type only)
+   --    No_Predicate_On_Actual              (Flag275)
+   --    No_Dynamic_Predicate_On_Actual      (Flag276)
    --    Type_Low_Bound                      (synth)
    --    Type_High_Bound                     (synth)
    --    (plus type attributes)
@@ -5780,6 +5790,8 @@ package Einfo is
    --    Non_Binary_Modulus                  (Flag58)   (base type only)
    --    Has_Biased_Representation           (Flag139)
    --    Has_Shift_Operator                  (Flag267)  (base type only)
+   --    No_Predicate_On_Actual              (Flag275)
+   --    No_Dynamic_Predicate_On_Actual      (Flag276)
    --    Type_Low_Bound                      (synth)
    --    Type_High_Bound                     (synth)
    --    (plus type attributes)
@@ -6082,6 +6094,8 @@ package Einfo is
    --    Static_Discrete_Predicate           (List25)
    --    Has_Biased_Representation           (Flag139)
    --    Has_Shift_Operator                  (Flag267)  (base type only)
+   --    No_Predicate_On_Actual              (Flag275)
+   --    No_Dynamic_Predicate_On_Actual      (Flag276)
    --    Type_Low_Bound                      (synth)
    --    Type_High_Bound                     (synth)
    --    (plus type attributes)
@@ -6751,7 +6765,9 @@ package Einfo is
    function Needs_No_Actuals                    (Id : E) return B;
    function Never_Set_In_Source                 (Id : E) return B;
    function Next_Inlined_Subprogram             (Id : E) return E;
+   function No_Dynamic_Predicate_On_Actual      (Id : E) return B;
    function No_Pool_Assigned                    (Id : E) return B;
+   function No_Predicate_On_Actual              (Id : E) return B;
    function No_Return                           (Id : E) return B;
    function No_Strict_Aliasing                  (Id : E) return B;
    function Non_Binary_Modulus                  (Id : E) return B;
@@ -7389,7 +7405,9 @@ package Einfo is
    procedure Set_Needs_No_Actuals                (Id : E; V : B := True);
    procedure Set_Never_Set_In_Source             (Id : E; V : B := True);
    procedure Set_Next_Inlined_Subprogram         (Id : E; V : E);
+   procedure Set_No_Dynamic_Predicate_On_Actual  (Id : E; V : B := True);
    procedure Set_No_Pool_Assigned                (Id : E; V : B := True);
+   procedure Set_No_Predicate_On_Actual          (Id : E; V : B := True);
    procedure Set_No_Return                       (Id : E; V : B := True);
    procedure Set_No_Strict_Aliasing              (Id : E; V : B := True);
    procedure Set_Non_Binary_Modulus              (Id : E; V : B := True);
@@ -8175,7 +8193,9 @@ package Einfo is
    pragma Inline (Next_Index);
    pragma Inline (Next_Inlined_Subprogram);
    pragma Inline (Next_Literal);
+   pragma Inline (No_Dynamic_Predicate_On_Actual);
    pragma Inline (No_Pool_Assigned);
+   pragma Inline (No_Predicate_On_Actual);
    pragma Inline (No_Return);
    pragma Inline (No_Strict_Aliasing);
    pragma Inline (Non_Binary_Modulus);
@@ -8612,7 +8632,9 @@ package Einfo is
    pragma Inline (Set_Needs_No_Actuals);
    pragma Inline (Set_Never_Set_In_Source);
    pragma Inline (Set_Next_Inlined_Subprogram);
+   pragma Inline (Set_No_Dynamic_Predicate_On_Actual);
    pragma Inline (Set_No_Pool_Assigned);
+   pragma Inline (Set_No_Predicate_On_Actual);
    pragma Inline (Set_No_Return);
    pragma Inline (Set_No_Strict_Aliasing);
    pragma Inline (Set_Non_Binary_Modulus);
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 679518c..db449d8 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/gcc/ada/sem_ch12.adb
@@ -10810,6 +10810,13 @@ package body Sem_Ch12 is
       Loc        : Source_Ptr;
       Subt       : Entity_Id;
 
+      procedure Diagnose_Predicated_Actual;
+      --  There are a number of constructs in which a discrete type with
+      --  predicates is illegal, e.g. as an index in an array type declaration.
+      --  If a generic type is used is such a construct in a generic package
+      --  declaration, it carries the flag No_Predicate_On_Actual. it is part
+      --  of the generic contract that the actual cannot have predicates.
+
       procedure Validate_Array_Type_Instance;
       procedure Validate_Access_Subprogram_Instance;
       procedure Validate_Access_Type_Instance;
@@ -10827,6 +10834,29 @@ package body Sem_Ch12 is
       --  Check that base types are the same and that the subtypes match
       --  statically. Used in several of the above.
 
+      ---------------------------------
+      --  Diagnose_Predicated_Actual --
+      ---------------------------------
+
+      procedure Diagnose_Predicated_Actual is
+      begin
+         if No_Predicate_On_Actual (A_Gen_T)
+           and then Has_Predicates (Act_T)
+         then
+            Error_Msg_NE
+              ("actual for& cannot be a type with predicate",
+                 Instantiation_Node, A_Gen_T);
+
+         elsif No_Dynamic_Predicate_On_Actual (A_Gen_T)
+           and then Has_Predicates (Act_T)
+           and then not Has_Static_Predicate_Aspect (Act_T)
+         then
+            Error_Msg_NE
+              ("actual for& cannot be a type with a dynamic predicate",
+                 Instantiation_Node, A_Gen_T);
+         end if;
+      end Diagnose_Predicated_Actual;
+
       --------------------
       -- Subtypes_Match --
       --------------------
@@ -11995,6 +12025,8 @@ package body Sem_Ch12 is
                   Abandon_Instantiation (Actual);
                end if;
 
+               Diagnose_Predicated_Actual;
+
             when N_Formal_Signed_Integer_Type_Definition =>
                if not Is_Signed_Integer_Type (Act_T) then
                   Error_Msg_NE
@@ -12003,6 +12035,8 @@ package body Sem_Ch12 is
                   Abandon_Instantiation (Actual);
                end if;
 
+               Diagnose_Predicated_Actual;
+
             when N_Formal_Modular_Type_Definition =>
                if not Is_Modular_Integer_Type (Act_T) then
                   Error_Msg_NE
@@ -12011,6 +12045,8 @@ package body Sem_Ch12 is
                   Abandon_Instantiation (Actual);
                end if;
 
+               Diagnose_Predicated_Actual;
+
             when N_Formal_Floating_Point_Definition =>
                if not Is_Floating_Point_Type (Act_T) then
                   Error_Msg_NE
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index bf720be..cc03f92 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -8255,6 +8255,15 @@ package body Sem_Ch13 is
                --  For discrete subtype, build the static predicate list
 
                if Is_Discrete_Type (Typ) then
+                  if not Is_Static_Subtype (Typ) then
+
+                     --  This can only happen in the presence of previous
+                     --  semantic errors.
+
+                     pragma Assert (Serious_Errors_Detected > 0);
+                     return;
+                  end if;
+
                   Build_Discrete_Static_Predicate (Typ, Expr, Object_Name);
 
                   --  If we don't get a static predicate list, it means that we
@@ -10123,7 +10132,7 @@ package body Sem_Ch13 is
       end if;
 
       --  For a record type, deal with variant parts. This has to be delayed
-      --  to this point, because of the issue of statically precicated
+      --  to this point, because of the issue of statically predicated
       --  subtypes, which we have to ensure are frozen before checking
       --  choices, since we need to have the static choice list set.
 
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index a2634ac..9e8969f 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -586,6 +586,10 @@ package body Sem_Ch3 is
    --  copying the record declaration for the derived base. In the tagged case
    --  the value returned is irrelevant.
 
+   procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id);
+   --  Propagate static and dynamic predicate flags from a parent to the
+   --  subtype in a subtype declaration with and without constraints.
+
    function Is_Valid_Constraint_Kind
      (T_Kind          : Type_Kind;
       Constraint_Kind : Node_Kind) return Boolean;
@@ -4514,14 +4518,13 @@ package body Sem_Ch3 is
 
             when Enumeration_Kind =>
                Set_Ekind                (Id, E_Enumeration_Subtype);
-               Set_Has_Dynamic_Predicate_Aspect
-                                        (Id, Has_Dynamic_Predicate_Aspect (T));
                Set_First_Literal        (Id, First_Literal (Base_Type (T)));
                Set_Scalar_Range         (Id, Scalar_Range       (T));
                Set_Is_Character_Type    (Id, Is_Character_Type  (T));
                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);
@@ -4544,6 +4547,7 @@ 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);
@@ -4551,6 +4555,7 @@ 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);
@@ -16793,6 +16798,18 @@ package body Sem_Ch3 is
       return Assoc_List;
    end Inherit_Components;
 
+   -----------------------------
+   -- Inherit_Predicate_Flags --
+   -----------------------------
+
+   procedure Inherit_Predicate_Flags (Subt, Par : Entity_Id) is
+   begin
+      Set_Has_Static_Predicate_Aspect (Subt,
+          Has_Static_Predicate_Aspect (Par));
+      Set_Has_Dynamic_Predicate_Aspect (Subt,
+          Has_Dynamic_Predicate_Aspect (Par));
+   end Inherit_Predicate_Flags;
+
    -----------------------
    -- Is_Null_Extension --
    -----------------------
@@ -19653,6 +19670,7 @@ 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);
@@ -19662,6 +19680,7 @@ package body Sem_Ch3 is
 
             when Integer_Kind =>
                Constrain_Integer (Def_Id, S);
+               Inherit_Predicate_Flags (Def_Id, Subtype_Mark_Id);
 
             when E_Record_Type     |
                  E_Record_Subtype  |
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 9106aa2..56db2bc 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -2509,6 +2509,9 @@ package body Sem_Ch5 is
             Bad_Predicated_Subtype_Use
               ("cannot use subtype& with non-static predicate for loop " &
                "iteration", DS, Entity (DS), Suggest_Static => True);
+
+         elsif Inside_A_Generic and then Is_Generic_Formal (Entity (DS)) then
+            Set_No_Dynamic_Predicate_On_Actual (Entity (DS));
          end if;
       end if;
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 204ae5f..237cc86 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -781,15 +781,52 @@ package body Sem_Util is
       Typ            : Entity_Id;
       Suggest_Static : Boolean := False)
    is
+      Gen            : Entity_Id;
    begin
-      if Has_Predicates (Typ) then
+      if Inside_A_Generic then
+         Gen := Current_Scope;
+         while Present (Gen) and then  Ekind (Gen) /= E_Generic_Package loop
+            Gen := Scope (Gen);
+         end loop;
+
+         if No (Gen) then
+            return;
+         end if;
+
+         if Is_Generic_Formal (Typ) then
+            Set_No_Predicate_On_Actual (Typ);
+         end if;
+
+      elsif Has_Predicates (Typ) then
          if Is_Generic_Actual_Type (Typ) then
-            Error_Msg_Warn := SPARK_Mode /= On;
-            Error_Msg_FE (Msg & "<<", N, Typ);
-            Error_Msg_F ("\Program_Error [<<", N);
-            Insert_Action (N,
-              Make_Raise_Program_Error (Sloc (N),
-                Reason => PE_Bad_Predicated_Generic_Type));
+
+            --  The restriction on loop parameters is only that the type
+            --  should have no dynamic predicates.
+
+            if Nkind (Parent (N)) = N_Loop_Parameter_Specification
+              and then not Has_Dynamic_Predicate_Aspect (Typ)
+              and then Is_Static_Subtype (Typ)
+            then
+               return;
+            end if;
+
+            Gen := Current_Scope;
+            while not Is_Generic_Instance (Gen) loop
+               Gen := Scope (Gen);
+            end loop;
+
+            pragma Assert (Present (Gen));
+
+            if Ekind (Gen) = E_Package and then In_Package_Body (Gen) then
+               Error_Msg_Warn := SPARK_Mode /= On;
+               Error_Msg_FE (Msg & "<<", N, Typ);
+               Error_Msg_F ("\Program_Error [<<", N);
+               Insert_Action (N,
+                 Make_Raise_Program_Error (Sloc (N),
+                   Reason => PE_Bad_Predicated_Generic_Type));
+            else
+               Error_Msg_FE (Msg & "<<", N, Typ);
+            end if;
 
          else
             Error_Msg_FE (Msg, N, Typ);