[Ada] Check bad use of predicates

[Arnaud Charlet]

This checks for some disallowed use of subtypes with predicates
as shown by the following test compiled with -gnat12 -gnatld7
-gnatj60:

     1. package Bad_Predicates is
     2.    -- This test should get compile-time errors
     3.
     4.    type Color is
     5.      (Red, Orange, Yellow, Green,
     6.       Blue, Indigo, Violet);
     7.    subtype RGB is Color with
     8.      Predicate =>
     9.        RGB = Red or RGB in Green .. Blue;
    10.    subtype Other_Color is Color with
    11.      Predicate => Other_Color not in RGB;
    12.
    13.    subtype Another_Color is Other_Color;
    14.
    15.    type Bad_Array is array
    16.      (Another_Color range <>) of Character;
              |
        >>> subtype "Another_Color" has predicate, not
            allowed as index subtype

    17.    --  ERROR: Subtype with predicate not
    18.    --         allowed as index subtype
    19.
    20.    type OK_Array is array
    21.      (Color range <>) of Character;
    22.
    23.    subtype Bad_Array_Subtype is
    24.      OK_Array (Another_Color);
                       |
        >>> subtype "Another_Color" has predicate, not
            allowed in index consraint

    25.    --  ERROR: Subtype with predicate not
    26.    --         allowed in index_constraint
    27.
    28.    OK : constant OK_Array := (Color => 'x');
    29.
    30.    Bad_Slice : constant OK_Array :=
    31.                  OK (Another_Color);
                             |
        >>> subtype "Another_Color" has predicate, not
            allowed in slice

    32.    --  ERROR: Subtype with predicate not
    33.    --         allowed in slice
    34.
    35.    protected type Prot is
    36.       entry Bad_Family
    37.               (Another_Color) (X : Integer);
                       |
        >>> subtype "Another_Color" has predicate, not
            allowed in entry family

    38.       --  ERROR: Subtype with predicate not
    39.       --         allowed in entry family
    40.    end Prot;
    41.
    42. end Bad_Predicates;

Tested on x86_64-pc-linux-gnu, committed on trunk

2010-10-22  Robert Dewar  <dewar@adacore.com>

	* sem_ch3.adb (Array_Type_Declaration): Error for subtype wi predicate
	for index type
	(Constrain_Index): Error of subtype wi predicate in index constraint
	* sem_ch9.adb (Analyze_Entry_Declaration): Error of subtype wi
	predicate in entry family.
	* sem_res.adb (Resolve_Slice): Error of type wi predicate in slice.

-------------- next part --------------
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165804)
+++ sem_ch3.adb	(working copy)
@@ -446,7 +446,7 @@ package body Sem_Ch3 is
       Related_Id   : Entity_Id;
       Suffix       : Character;
       Suffix_Index : Nat);
-   --  Process an index constraint in a constrained array declaration. The
+   --  Process an index constraint S in a constrained array declaration. The
    --  constraint can be a subtype name, or a range with or without an explicit
    --  subtype mark. The index is the corresponding index of the unconstrained
    --  array. The Related_Id and Suffix parameters are used to build the
@@ -4424,6 +4424,17 @@ package body Sem_Ch3 is
          end if;
 
          Make_Index (Index, P, Related_Id, Nb_Index);
+
+         --  Check error of subtype with predicate for index type
+
+         if Has_Predicates (Etype (Index)) then
+            Error_Msg_NE
+              ("subtype& has predicate, not allowed as index subtype",
+               Index, Etype (Index));
+         end if;
+
+         --  Move to next index
+
          Next_Index (Index);
          Nb_Index := Nb_Index + 1;
       end loop;
@@ -11332,6 +11343,13 @@ package body Sem_Ch3 is
 
             elsif Base_Type (Entity (S)) /= Base_Type (T) then
                Wrong_Type (S, Base_Type (T));
+
+            --  Check error of subtype with predicate in index constraint
+
+            elsif Has_Predicates (Entity (S)) then
+               Error_Msg_NE
+                 ("subtype& has predicate, not allowed in index consraint",
+                  S, Entity (S));
             end if;
 
             return;
Index: sem_ch9.adb
===================================================================
--- sem_ch9.adb	(revision 165803)
+++ sem_ch9.adb	(working copy)
@@ -879,19 +879,36 @@ package body Sem_Ch9 is
       Generate_Definition (Def_Id);
       Tasking_Used := True;
 
+      --  Case of no discrete subtype definition
+
       if No (D_Sdef) then
          Set_Ekind (Def_Id, E_Entry);
+
+      --  Processing for discrete subtype definition present
+
       else
          Enter_Name (Def_Id);
          Set_Ekind (Def_Id, E_Entry_Family);
          Analyze (D_Sdef);
          Make_Index (D_Sdef, N, Def_Id);
+
+         --  Check subtype with predicate in entry family
+
+         if Has_Predicates (Etype (D_Sdef)) then
+            Error_Msg_NE
+              ("subtype& has predicate, not allowed in entry family",
+               D_Sdef, Etype (D_Sdef));
+         end if;
       end if;
 
+      --  Decorate Def_Id
+
       Set_Etype          (Def_Id, Standard_Void_Type);
       Set_Convention     (Def_Id, Convention_Entry);
       Set_Accept_Address (Def_Id, New_Elmt_List);
 
+      --  Process formals
+
       if Present (Formals) then
          Set_Scope (Def_Id, Current_Scope);
          Push_Scope (Def_Id);
Index: sem_res.adb
===================================================================
--- sem_res.adb	(revision 165803)
+++ sem_res.adb	(working copy)
@@ -8478,7 +8478,16 @@ package body Sem_Res is
 
       Set_Slice_Subtype (N);
 
-      if Nkind (Drange) = N_Range then
+      --  Check bad use of type with predicates
+
+      if Has_Predicates (Etype (Drange)) then
+         Error_Msg_NE
+           ("subtype& has predicate, not allowed in slice",
+            Drange, Etype (Drange));
+
+      --  Otherwise here is where we check suspicious indexes
+
+      elsif Nkind (Drange) = N_Range then
          Warn_On_Suspicious_Index (Name, Low_Bound  (Drange));
          Warn_On_Suspicious_Index (Name, High_Bound (Drange));
       end if;