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

	* a-except-2005.adb (Rmsg_18): New message text.
	* a-except.adb (Rmsg_18): New message text.
	* atree.adb (List25): New function
	(Set_List25): New procedure
	* atree.ads (List25): New function
	(Set_List25): New procedure
	* einfo.adb (Static_Predicate): Is now a list
	(OK_To_Reference): Present in all entities
	* einfo.ads (Static_Predicate): Is now a list
	(OK_To_Reference): Applies to all entities
	* exp_ch13.adb (Build_Predicate_Function): Moved to Sem_Ch13
	* sem_attr.adb (Bad_Attribute_For_Predicate): Call
	Bad_Predicated_Subtype_Use.
	* sem_case.ads, sem_case.adb: Major surgery to deal with predicated
	subtype case.
	* sem_ch13.adb (Build_Predicate_Function): Moved from Exp_Ch13 to
	Sem_Ch13.
	(Build_Static_Predicate): New procedure handles static predicates.
	* sem_ch3.adb (Analyze_Subtype_Declaration): Delay freeze on subtype
	with no constraint if ancestor subtype has predicates.
	(Analyze_Variant_Part): New calling sequence for Analyze_Choices
	* sem_ch4.adb (Junk_Operand): Don't complain about OK_To_Reference
	entity.
	(Analyze_Case_Expression): New calling sequence for Analyze_Choices
	* sem_ch5.adb (Analyze_Case_Statement): New calling sequence for
	Analyze_Choices.
	* sem_util.ads, sem_util.adb (Bad_Predicated_Subtype_Use): New procedure
	* types.ads (PE_Bad_Predicated_Generic_Type): Replaces
	PE_Bad_Attribute_For_Predicate.
	* atree.h: Add definition of List25.



git-svn-id: svn+ssh://gcc.gnu.org/svn/gcc/trunk@165828 138bc75d-0d04-0410-961f-82ee72b054a4

19 files changed, 919 insertions, 517 deletions

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 8dbeb57c7f6..e5274a749cc 100644
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,36 @@
+2010-10-22  Robert Dewar  <dewar@adacore.com>
+
+	* a-except-2005.adb (Rmsg_18): New message text.
+	* a-except.adb (Rmsg_18): New message text.
+	* atree.adb (List25): New function
+	(Set_List25): New procedure
+	* atree.ads (List25): New function
+	(Set_List25): New procedure
+	* einfo.adb (Static_Predicate): Is now a list
+	(OK_To_Reference): Present in all entities
+	* einfo.ads (Static_Predicate): Is now a list
+	(OK_To_Reference): Applies to all entities
+	* exp_ch13.adb (Build_Predicate_Function): Moved to Sem_Ch13
+	* sem_attr.adb (Bad_Attribute_For_Predicate): Call
+	Bad_Predicated_Subtype_Use.
+	* sem_case.ads, sem_case.adb: Major surgery to deal with predicated
+	subtype case.
+	* sem_ch13.adb (Build_Predicate_Function): Moved from Exp_Ch13 to
+	Sem_Ch13.
+	(Build_Static_Predicate): New procedure handles static predicates.
+	* sem_ch3.adb (Analyze_Subtype_Declaration): Delay freeze on subtype
+	with no constraint if ancestor subtype has predicates.
+	(Analyze_Variant_Part): New calling sequence for Analyze_Choices
+	* sem_ch4.adb (Junk_Operand): Don't complain about OK_To_Reference
+	entity.
+	(Analyze_Case_Expression): New calling sequence for Analyze_Choices
+	* sem_ch5.adb (Analyze_Case_Statement): New calling sequence for
+	Analyze_Choices.
+	* sem_util.ads, sem_util.adb (Bad_Predicated_Subtype_Use): New procedure
+	* types.ads (PE_Bad_Predicated_Generic_Type): Replaces
+	PE_Bad_Attribute_For_Predicate.
+	* atree.h: Add definition of List25.
+
 2010-10-22  Jerome Lambourg  <lambourg@adacore.com>
 
 	* gnatlink.adb (Process_Binder_File): Remove CLI-specific code, now
diff --git a/gcc/ada/a-except-2005.adb b/gcc/ada/a-except-2005.adb
index 72396969c12..cbf1e4deb89 100644
--- a/gcc/ada/a-except-2005.adb
+++ b/gcc/ada/a-except-2005.adb
@@ -588,8 +588,8 @@ package body Ada.Exceptions is
    Rmsg_16 : constant String := "attempt to take address of"       &
                                 " intrinsic subprogram"            & NUL;
    Rmsg_17 : constant String := "all guards closed"                & NUL;
-   Rmsg_18 : constant String := "attribute not allowed for "       &
-                                " generic subtype with predicate"  & NUL;
+   Rmsg_18 : constant String := "improper use of generic subtype"  &
+                                " with predicate"                  & NUL;
    Rmsg_19 : constant String := "Current_Task referenced in entry" &
                                 " body"                            & NUL;
    Rmsg_20 : constant String := "duplicated entry address"         & NUL;
diff --git a/gcc/ada/a-except.adb b/gcc/ada/a-except.adb
index 8471dfe99b1..e80e264fe0f 100644
--- a/gcc/ada/a-except.adb
+++ b/gcc/ada/a-except.adb
@@ -520,8 +520,8 @@ package body Ada.Exceptions is
    Rmsg_16 : constant String := "attempt to take address of"       &
                                 " intrinsic subprogram"            & NUL;
    Rmsg_17 : constant String := "all guards closed"                & NUL;
-   Rmsg_18 : constant String := "attribute not allowed for "       &
-                                " generic subtype with predicate"  & NUL;
+   Rmsg_18 : constant String := "improper use of generic subtype"  &
+                                " with predicate"                  & NUL;
    Rmsg_19 : constant String := "Current_Task referenced in entry" &
                                 " body"                            & NUL;
    Rmsg_20 : constant String := "duplicated entry address"         & NUL;
diff --git a/gcc/ada/atree.adb b/gcc/ada/atree.adb
index 957cca5b84c..5426fab7d02 100644
--- a/gcc/ada/atree.adb
+++ b/gcc/ada/atree.adb
@@ -2400,6 +2400,12 @@ package body Atree is
          return List_Id (Nodes.Table (N + 2).Field7);
       end List14;
 
+      function List25 (N : Node_Id) return List_Id is
+      begin
+         pragma Assert (Nkind (N) in N_Entity);
+         return List_Id (Nodes.Table (N + 4).Field7);
+      end List25;
+
       function Elist1 (N : Node_Id) return Elist_Id is
          pragma Assert (N <= Nodes.Last);
          Value : constant Union_Id := Nodes.Table (N).Field1;
@@ -4657,6 +4663,12 @@ package body Atree is
          Nodes.Table (N + 2).Field7 := Union_Id (Val);
       end Set_List14;
 
+      procedure Set_List25 (N : Node_Id; Val : List_Id) is
+      begin
+         pragma Assert (Nkind (N) in N_Entity);
+         Nodes.Table (N + 4).Field7 := Union_Id (Val);
+      end Set_List25;
+
       procedure Set_Elist1 (N : Node_Id; Val : Elist_Id) is
       begin
          Nodes.Table (N).Field1 := Union_Id (Val);
diff --git a/gcc/ada/atree.ads b/gcc/ada/atree.ads
index 31b4391e4cc..51921cdb994 100644
--- a/gcc/ada/atree.ads
+++ b/gcc/ada/atree.ads
@@ -1096,6 +1096,9 @@ package Atree is
       function List14 (N : Node_Id) return List_Id;
       pragma Inline (List14);
 
+      function List25 (N : Node_Id) return List_Id;
+      pragma Inline (List25);
+
       function Elist1 (N : Node_Id) return Elist_Id;
       pragma Inline (Elist1);
 
@@ -2159,6 +2162,9 @@ package Atree is
       procedure Set_List14 (N : Node_Id; Val : List_Id);
       pragma Inline (Set_List14);
 
+      procedure Set_List25 (N : Node_Id; Val : List_Id);
+      pragma Inline (Set_List25);
+
       procedure Set_Elist1 (N : Node_Id; Val : Elist_Id);
       pragma Inline (Set_Elist1);
 
diff --git a/gcc/ada/atree.h b/gcc/ada/atree.h
index e6a429c01ef..4cef407ebd5 100644
--- a/gcc/ada/atree.h
+++ b/gcc/ada/atree.h
@@ -421,6 +421,7 @@ extern Node_Id Current_Error_Node;
 #define List5(N)      Field5  (N)
 #define List10(N)     Field10 (N)
 #define List14(N)     Field14 (N)
+#define List25(N)     Field25 (N)
 
 #define Elist1(N)     Field1  (N)
 #define Elist2(N)     Field2  (N)
diff --git a/gcc/ada/einfo.adb b/gcc/ada/einfo.adb
index ecc054d193c..50463979ca3 100644
--- a/gcc/ada/einfo.adb
+++ b/gcc/ada/einfo.adb
@@ -215,7 +215,7 @@ package body Einfo is
    --    Debug_Renaming_Link             Node25
    --    DT_Offset_To_Top_Func           Node25
    --    PPC_Wrapper                     Node25
-   --    Static_Predicate                Node25
+   --    Static_Predicate                List25
    --    Task_Body_Procedure             Node25
 
    --    Dispatch_Table_Wrappers         Elist26
@@ -2316,7 +2316,6 @@ package body Einfo is
 
    function OK_To_Reference (Id : E) return B is
    begin
-      pragma Assert (Is_Type (Id));
       return Flag249 (Id);
    end OK_To_Reference;
 
@@ -2621,10 +2620,10 @@ package body Einfo is
       return Node24 (Id);
    end Spec_PPC_List;
 
-   function Static_Predicate (Id : E) return N is
+   function Static_Predicate (Id : E) return S is
    begin
       pragma Assert (Is_Discrete_Type (Id));
-      return Node25 (Id);
+      return List25 (Id);
    end Static_Predicate;
 
    function Storage_Size_Variable (Id : E) return E is
@@ -4811,7 +4810,6 @@ package body Einfo is
 
    procedure Set_OK_To_Reference (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Type (Id));
       Set_Flag249 (Id, V);
    end Set_OK_To_Reference;
 
@@ -5127,14 +5125,14 @@ package body Einfo is
       Set_Node24 (Id, V);
    end Set_Spec_PPC_List;
 
-   procedure Set_Static_Predicate (Id : E; V : N) is
+   procedure Set_Static_Predicate (Id : E; V : S) is
    begin
       pragma Assert
         (Ekind_In (Id, E_Enumeration_Subtype,
                        E_Modular_Integer_Subtype,
                        E_Signed_Integer_Subtype)
           and then Has_Predicates (Id));
-      Set_Node25 (Id, V);
+      Set_List25 (Id, V);
    end Set_Static_Predicate;
 
    procedure Set_Storage_Size_Variable (Id : E; V : E) is
diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 30427a079b7..6b5a14ac356 100644
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3152,10 +3152,10 @@ package Einfo is
 --       formals as a value of type Pos.
 
 --    OK_To_Reference (Flag249)
---       Present in all entities for types and subtypes. If set it indicates
---       that a naked reference to the type is permitted within an expression
---       that is being analyzed or preanalyed (for example, a type name may
---       be referenced within the Invariant aspect expression for the type).
+--       Present in all entities. If set it indicates that a naked reference to
+--       the entity is permitted within an expression that is being preanalyzed
+--       (for example, a type name may be referenced within the Invariant
+--       or Predicate aspect expression for a type).
 
 --    OK_To_Rename (Flag247)
 --       Present only in entities for variables. If this flag is set, it
@@ -3609,11 +3609,14 @@ package Einfo is
 --       textual appearance. Note that this includes precondition/postcondition
 --       pragmas generated to correspond to Pre/Post aspects.
 
---    Static_Predicate (Node25)
+--    Static_Predicate (List25)
 --       Present in discrete types/subtypes with predicates (Has_Predicates
---       set True). Set for a subtype that has a predicate that is considered
---       static. Points to the fully analyzed predicate expression, which is
---       always a membership test (possibly a set membership).
+--       set True). Points to a list of expression and N_Range nodes that
+--       represent the predicate in canonical form. The canonical form has
+--       entries sorted in ascending order, with all duplicates eliminated,
+--       and adjacent ranges coalesced, so that there is always a gap in the
+--       values between successive entries. The entries in this list are
+--       fully analyzed.
 
 --    Storage_Size_Variable (Node15) [implementation base type only]
 --       Present in access types and task type entities. This flag is set
@@ -4735,6 +4738,7 @@ package Einfo is
    --    Needs_Debug_Info                    (Flag147)
    --    Never_Set_In_Source                 (Flag115)
    --    No_Return                           (Flag113)
+   --    OK_To_Reference                     (Flag249)
    --    Overlays_Constant                   (Flag243)
    --    Referenced                          (Flag156)
    --    Referenced_As_LHS                   (Flag36)
@@ -4817,7 +4821,6 @@ package Einfo is
    --    Known_To_Have_Preelab_Init          (Flag207)
    --    Must_Be_On_Byte_Boundary            (Flag183)
    --    Must_Have_Preelab_Init              (Flag208)
-   --    OK_To_Reference                     (Flag249)
    --    Optimize_Alignment_Space            (Flag241)
    --    Optimize_Alignment_Time             (Flag242)
    --    Size_Depends_On_Discriminant        (Flag177)
@@ -5073,7 +5076,7 @@ package Einfo is
    --    First_Literal                       (Node17)
    --    Scalar_Range                        (Node20)
    --    Enum_Pos_To_Rep                     (Node23)   (type only)
-   --    Static_Predicate                    (Node25)
+   --    Static_Predicate                    (List25)
    --    Has_Biased_Representation           (Flag139)
    --    Has_Contiguous_Rep                  (Flag181)
    --    Has_Enumeration_Rep_Clause          (Flag66)
@@ -5275,7 +5278,7 @@ package Einfo is
    --    Modulus                             (Uint17)    (base type only)
    --    Original_Array_Type                 (Node21)
    --    Scalar_Range                        (Node20)
-   --    Static_Predicate                    (Node25)
+   --    Static_Predicate                    (List25)
    --    Non_Binary_Modulus                  (Flag58)    (base type only)
    --    Has_Biased_Representation           (Flag139)
    --    Type_Low_Bound                      (synth)
@@ -5545,7 +5548,7 @@ package Einfo is
    --  E_Signed_Integer_Type
    --  E_Signed_Integer_Subtype
    --    Scalar_Range                        (Node20)
-   --    Static_Predicate                    (Node25)
+   --    Static_Predicate                    (List25)
    --    Has_Biased_Representation           (Flag139)
    --    Type_Low_Bound                      (synth)
    --    Type_High_Bound                     (synth)
@@ -6241,7 +6244,7 @@ package Einfo is
    function Small_Value                         (Id : E) return R;
    function Spec_Entity                         (Id : E) return E;
    function Spec_PPC_List                       (Id : E) return N;
-   function Static_Predicate                    (Id : E) return N;
+   function Static_Predicate                    (Id : E) return S;
    function Storage_Size_Variable               (Id : E) return E;
    function Static_Elaboration_Desired          (Id : E) return B;
    function Static_Initialization               (Id : E) return N;
@@ -6829,7 +6832,7 @@ package Einfo is
    procedure Set_Small_Value                     (Id : E; V : R);
    procedure Set_Spec_Entity                     (Id : E; V : E);
    procedure Set_Spec_PPC_List                   (Id : E; V : N);
-   procedure Set_Static_Predicate                (Id : E; V : N);
+   procedure Set_Static_Predicate                (Id : E; V : S);
    procedure Set_Storage_Size_Variable           (Id : E; V : E);
    procedure Set_Static_Elaboration_Desired      (Id : E; V : B);
    procedure Set_Static_Initialization           (Id : E; V : N);
diff --git a/gcc/ada/exp_ch13.adb b/gcc/ada/exp_ch13.adb
index e977bf91fb5..f3de66c6a12 100644
--- a/gcc/ada/exp_ch13.adb
+++ b/gcc/ada/exp_ch13.adb
@@ -26,8 +26,6 @@
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
-with Elists;   use Elists;
-with Errout;   use Errout;
 with Exp_Ch3;  use Exp_Ch3;
 with Exp_Ch6;  use Exp_Ch6;
 with Exp_Imgv; use Exp_Imgv;
@@ -39,8 +37,6 @@ with Nmake;    use Nmake;
 with Opt;      use Opt;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
-with Sem_Aux;  use Sem_Aux;
-with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch7;  use Sem_Ch7;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Eval; use Sem_Eval;
@@ -54,313 +50,6 @@ with Validsw;  use Validsw;
 
 package body Exp_Ch13 is
 
-   -----------------------
-   -- Local Subprograms --
-   -----------------------
-
-   procedure Build_Predicate_Function
-     (Typ   : Entity_Id;
-      FDecl : out Node_Id;
-      FBody : out Node_Id);
-   --  If Typ has predicates (indicated by Has_Predicates being set for Typ,
-   --  then either there are pragma Invariant entries on the rep chain for the
-   --  type (note that Predicate aspects are converted to pragam Predicate), or
-   --  there are inherited aspects from a parent type, or ancestor subtypes,
-   --  or interfaces. This procedure builds the spec and body for the Predicate
-   --  function that tests these predicates, returning them in PDecl and Pbody
-   --  and setting Predicate_Procedure for Typ. In some error situations no
-   --  procedure is built, in which case PDecl/PBody are empty on return.
-
-   ------------------------------
-   -- Build_Predicate_Function --
-   ------------------------------
-
-   --  The procedure that is constructed here has the form
-
-   --  function typPredicate (Ixxx : typ) return Boolean is
-   --  begin
-   --     return
-   --        exp1 and then exp2 and then ...
-   --        and then typ1Predicate (typ1 (Ixxx))
-   --        and then typ2Predicate (typ2 (Ixxx))
-   --        and then ...;
-   --  end typPredicate;
-
-   --  Here exp1, and exp2 are expressions from Predicate pragmas. Note that
-   --  this is the point at which these expressions get analyzed, providing the
-   --  required delay, and typ1, typ2, are entities from which predicates are
-   --  inherited. Note that we do NOT generate Check pragmas, that's because we
-   --  use this function even if checks are off, e.g. for membership tests.
-
-   procedure Build_Predicate_Function
-     (Typ   : Entity_Id;
-      FDecl : out Node_Id;
-      FBody : out Node_Id)
-   is
-      Loc  : constant Source_Ptr := Sloc (Typ);
-      Spec : Node_Id;
-      SId  : Entity_Id;
-
-      Expr : Node_Id;
-      --  This is the expression for the return statement in the function. It
-      --  is build by connecting the component predicates with AND THEN.
-
-      procedure Add_Call (T : Entity_Id);
-      --  Includes a call to the predicate function for type T in Expr if T
-      --  has predicates and Predicate_Function (T) is non-empty.
-
-      procedure Add_Predicates;
-      --  Appends expressions for any Predicate pragmas in the rep item chain
-      --  Typ to Expr. Note that we look only at items for this exact entity.
-      --  Inheritance of predicates for the parent type is done by calling the
-      --  Predicate_Function of the parent type, using Add_Call above.
-
-      Object_Name : constant Name_Id := New_Internal_Name ('I');
-      --  Name for argument of Predicate procedure
-
-      --------------
-      -- Add_Call --
-      --------------
-
-      procedure Add_Call (T : Entity_Id) is
-         Exp : Node_Id;
-
-      begin
-         if Present (T) and then Present (Predicate_Function (T)) then
-            Set_Has_Predicates (Typ);
-
-            --  Build the call to the predicate function of T
-
-            Exp :=
-              Make_Predicate_Call
-                (T,
-                 Convert_To (T,
-                   Make_Identifier (Loc, Chars => Object_Name)));
-
-            --  Add call to evolving expression, using AND THEN if needed
-
-            if No (Expr) then
-               Expr := Exp;
-            else
-               Expr :=
-                 Make_And_Then (Loc,
-                   Left_Opnd  => Relocate_Node (Expr),
-                   Right_Opnd => Exp);
-            end if;
-
-            --  Output info message on inheritance if required
-
-            if Opt.List_Inherited_Aspects then
-               Error_Msg_Sloc := Sloc (Predicate_Function (T));
-               Error_Msg_Node_2 := T;
-               Error_Msg_N ("?info: & inherits predicate from & #", Typ);
-            end if;
-         end if;
-      end Add_Call;
-
-      --------------------
-      -- Add_Predicates --
-      --------------------
-
-      procedure Add_Predicates is
-         Ritem : Node_Id;
-         Arg1  : Node_Id;
-         Arg2  : Node_Id;
-
-         function Replace_Node (N : Node_Id) return Traverse_Result;
-         --  Process single node for traversal to replace type references
-
-         procedure Replace_Type is new Traverse_Proc (Replace_Node);
-         --  Traverse an expression changing every occurrence of an entity
-         --  reference to type T with a reference to the object argument.
-
-         ------------------
-         -- Replace_Node --
-         ------------------
-
-         function Replace_Node (N : Node_Id) return Traverse_Result is
-         begin
-            --  Case of entity name referencing the type
-
-            if Is_Entity_Name (N) and then Entity (N) = Typ then
-
-               --  Replace with object
-
-               Rewrite (N,
-                 Make_Identifier (Loc,
-                   Chars => Object_Name));
-
-               --  All done with this node
-
-               return Skip;
-
-            --  Not an occurrence of the type entity, keep going
-
-            else
-               return OK;
-            end if;
-         end Replace_Node;
-
-      --  Start of processing for Add_Predicates
-
-      begin
-         Ritem := First_Rep_Item (Typ);
-         while Present (Ritem) loop
-            if Nkind (Ritem) = N_Pragma
-              and then Pragma_Name (Ritem) = Name_Predicate
-            then
-               Arg1 := First (Pragma_Argument_Associations (Ritem));
-               Arg2 := Next (Arg1);
-
-               Arg1 := Get_Pragma_Arg (Arg1);
-               Arg2 := Get_Pragma_Arg (Arg2);
-
-               --  See if this predicate pragma is for the current type
-
-               if Entity (Arg1) = Typ then
-
-                  --  We have a match, this entry is for our subtype
-
-                  --  First We need to replace any occurrences of the name of
-                  --  the type with references to the object. We do this by
-                  --  first doing a preanalysis, to identify all the entities,
-                  --  then we traverse looking for the type entity, doing the
-                  --  needed substitution. The preanalysis is done with the
-                  --  special OK_To_Reference flag set on the type, so that if
-                  --  we get an occurrence of this type, it will be recognized
-                  --  as legitimate.
-
-                  Set_OK_To_Reference (Typ, True);
-                  Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
-                  Set_OK_To_Reference (Typ, False);
-                  Replace_Type (Arg2);
-
-                  --  OK, replacement complete, now we can add the expression
-
-                  if No (Expr) then
-                     Expr := Relocate_Node (Arg2);
-                  else
-                     Expr :=
-                       Make_And_Then (Loc,
-                         Left_Opnd  => Relocate_Node (Expr),
-                         Right_Opnd => Relocate_Node (Arg2));
-                  end if;
-               end if;
-            end if;
-
-            Next_Rep_Item (Ritem);
-         end loop;
-      end Add_Predicates;
-
-   --  Start of processing for Build_Predicate_Function
-
-   begin
-      --  Initialize for construction of statement list
-
-      Expr  := Empty;
-      FDecl := Empty;
-      FBody := Empty;
-
-      --  Return if already built or if type does not have predicates
-
-      if not Has_Predicates (Typ)
-        or else Present (Predicate_Function (Typ))
-      then
-         return;
-      end if;
-
-      --  Add Predicates for the current type
-
-      Add_Predicates;
-
-      --  Add predicates for ancestor if present
-
-      declare
-         Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
-      begin
-         if Present (Atyp) then
-            Add_Call (Atyp);
-         end if;
-      end;
-
-      --  Add predicates of any interfaces of a tagged type
-
-      if Is_Tagged_Type (Typ) then
-         declare
-            Iface_List : Elist_Id;
-            Elmt       : Elmt_Id;
-
-         begin
-            Collect_Interfaces (Typ, Iface_List);
-
-            if Present (Iface_List) then
-               loop
-                  Elmt := First_Elmt (Iface_List);
-                  exit when No (Elmt);
-
-                  Add_Call (Node (Elmt));
-                  Remove_Elmt (Iface_List, Elmt);
-               end loop;
-            end if;
-         end;
-      end if;
-
-      if Present (Expr) then
-
-         --  Build function declaration
-
-         pragma Assert (Has_Predicates (Typ));
-         SId :=
-           Make_Defining_Identifier (Loc,
-             Chars => New_External_Name (Chars (Typ), "Predicate"));
-         Set_Has_Predicates (SId);
-         Set_Predicate_Function (Typ, SId);
-
-         Spec :=
-           Make_Function_Specification (Loc,
-             Defining_Unit_Name       => SId,
-             Parameter_Specifications => New_List (
-               Make_Parameter_Specification (Loc,
-                 Defining_Identifier =>
-                   Make_Defining_Identifier (Loc, Chars => Object_Name),
-                 Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
-             Result_Definition        =>
-               New_Occurrence_Of (Standard_Boolean, Loc));
-
-         FDecl :=
-           Make_Subprogram_Declaration (Loc,
-             Specification => Spec);
-
-         --  Build function body
-
-         SId :=
-           Make_Defining_Identifier (Loc,
-             Chars => New_External_Name (Chars (Typ), "Predicate"));
-
-         Spec :=
-           Make_Function_Specification (Loc,
-             Defining_Unit_Name       => SId,
-             Parameter_Specifications => New_List (
-               Make_Parameter_Specification (Loc,
-                 Defining_Identifier =>
-                   Make_Defining_Identifier (Loc, Chars => Object_Name),
-                 Parameter_Type =>
-                   New_Occurrence_Of (Typ, Loc))),
-             Result_Definition        =>
-               New_Occurrence_Of (Standard_Boolean, Loc));
-
-         FBody :=
-           Make_Subprogram_Body (Loc,
-             Specification              => Spec,
-             Declarations               => Empty_List,
-             Handled_Statement_Sequence =>
-               Make_Handled_Sequence_Of_Statements (Loc,
-                 Statements => New_List (
-                   Make_Simple_Return_Statement (Loc,
-                     Expression => Expr))));
-      end if;
-   end Build_Predicate_Function;
-
    ------------------------------------------
    -- Expand_N_Attribute_Definition_Clause --
    ------------------------------------------
@@ -725,24 +414,6 @@ package body Exp_Ch13 is
          Rewrite (N, Make_Null_Statement (Sloc (N)));
       end if;
 
-      --  If freezing a type entity which has predicates, this is where we
-      --  build and insert the predicate function for the type.
-
-      if Is_Type (E) and then Has_Predicates (E) then
-         declare
-            FDecl : Node_Id;
-            FBody : Node_Id;
-
-         begin
-            Build_Predicate_Function (E, FDecl, FBody);
-
-            if Present (FDecl) then
-               Insert_After (N, FBody);
-               Insert_After (N, FDecl);
-            end if;
-         end;
-      end if;
-
       --  Pop scope if we installed one for the analysis
 
       if In_Other_Scope then
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 086797550f9..20a7829dd0b 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -215,7 +215,8 @@ package body Sem_Attr is
       --  Output error message for use of a predicate (First, Last, Range) not
       --  allowed with a type that has predicates. If the type is a generic
       --  actual, then the message is a warning, and we generate code to raise
-      --  program error with an appropriate reason.
+      --  program error with an appropriate reason. No error message is given
+      --  for internally generated uses of the attributes.
 
       procedure Check_Array_Or_Scalar_Type;
       --  Common procedure used by First, Last, Range attribute to check
@@ -838,23 +839,10 @@ package body Sem_Attr is
 
       procedure Bad_Attribute_For_Predicate is
       begin
-         if Has_Predicates (P_Type) then
+         if Comes_From_Source (N) then
             Error_Msg_Name_1 := Aname;
-
-            if Is_Generic_Actual_Type (P_Type) then
-               Error_Msg_F
-                 ("type& has predicates, attribute % not allowed?", P);
-               Error_Msg_F
-                 ("\?Program_Error will be raised at run time", P);
-               Rewrite (N,
-                 Make_Raise_Program_Error (Loc,
-                   Reason => PE_Bad_Attribute_For_Predicate));
-
-            else
-               Error_Msg_F
-                 ("type& has predicates, attribute % not allowed", P);
-               Error_Attr;
-            end if;
+            Bad_Predicated_Subtype_Use
+              (P_Type, N, "type& has predicates, attribute % not allowed");
          end if;
       end Bad_Attribute_For_Predicate;
 
diff --git a/gcc/ada/sem_case.adb b/gcc/ada/sem_case.adb
index fc8806a036f..216d709d6bc 100644
--- a/gcc/ada/sem_case.adb
+++ b/gcc/ada/sem_case.adb
@@ -32,7 +32,6 @@ with Nmake;    use Nmake;
 with Opt;      use Opt;
 with Sem;      use Sem;
 with Sem_Aux;  use Sem_Aux;
-with Sem_Case; use Sem_Case;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
 with Sem_Util; use Sem_Util;
@@ -43,23 +42,31 @@ with Sinfo;    use Sinfo;
 with Tbuild;   use Tbuild;
 with Uintp;    use Uintp;
 
+with Ada.Unchecked_Deallocation;
+
 with GNAT.Heap_Sort_G;
 
 package body Sem_Case is
 
+   type Choice_Bounds is record
+     Lo   : Node_Id;
+     Hi   : Node_Id;
+     Node : Node_Id;
+   end record;
+   --  Represent one choice bounds entry with Lo and Hi values, Node points
+   --  to the choice node itself.
+
+   type Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
+   --  Table type used to sort the choices present in a case statement, array
+   --  aggregate or record variant. The actual entries are stored in 1 .. Last,
+   --  but we have a 0 entry for convenience in sorting.
+
    -----------------------
    -- Local Subprograms --
    -----------------------
 
-   type Sort_Choice_Table_Type is array (Nat range <>) of Choice_Bounds;
-   --  This new array type is used as the actual table type for sorting
-   --  discrete choices. The reason for not using Choice_Table_Type, is that
-   --  in Sort_Choice_Table_Type we reserve entry 0 for the sorting algorithm
-   --  (this is not absolutely necessary but it makes the code more
-   --  efficient).
-
    procedure Check_Choices
-     (Choice_Table   : in out Sort_Choice_Table_Type;
+     (Choice_Table   : in out Choice_Table_Type;
       Bounds_Type    : Entity_Id;
       Subtyp         : Entity_Id;
       Others_Present : Boolean;
@@ -101,7 +108,7 @@ package body Sem_Case is
    -------------------
 
    procedure Check_Choices
-     (Choice_Table    : in out Sort_Choice_Table_Type;
+     (Choice_Table   : in out Choice_Table_Type;
       Bounds_Type    : Entity_Id;
       Subtyp         : Entity_Id;
       Others_Present : Boolean;
@@ -321,7 +328,9 @@ package body Sem_Case is
             Issue_Msg (Prev_Hi + 1, Lo - 1);
          end if;
 
-         Prev_Hi := Hi;
+         if Hi > Prev_Hi then
+            Prev_Hi := Hi;
+         end if;
       end loop;
 
       if not Others_Present and then Expr_Value (Bounds_Hi) > Hi then
@@ -511,7 +520,7 @@ package body Sem_Case is
    --  Start of processing for Expand_Others_Choice
 
    begin
-      if Case_Table'Length = 0 then
+      if Case_Table'Last = 0 then
 
          --  Special case: only an others case is present.
          --  The others case covers the full range of the type.
@@ -537,9 +546,9 @@ package body Sem_Case is
          Exp_Hi := Type_High_Bound (Base_Type (Choice_Type));
       end if;
 
-      Lo := Expr_Value (Case_Table (Case_Table'First).Lo);
-      Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
-      Previous_Hi := Expr_Value (Case_Table (Case_Table'First).Hi);
+      Lo := Expr_Value (Case_Table (1).Lo);
+      Hi := Expr_Value (Case_Table (1).Hi);
+      Previous_Hi := Expr_Value (Case_Table (1).Hi);
 
       --  Build the node for any missing choices that are smaller than any
       --  explicit choices given in the case.
@@ -551,7 +560,7 @@ package body Sem_Case is
       --  Build the nodes representing any missing choices that lie between
       --  the explicit ones given in the case.
 
-      for J in Case_Table'First + 1 .. Case_Table'Last loop
+      for J in 2 .. Case_Table'Last loop
          Lo := Expr_Value (Case_Table (J).Lo);
          Hi := Expr_Value (Case_Table (J).Hi);
 
@@ -588,7 +597,6 @@ package body Sem_Case is
 
    procedure No_OP (C : Node_Id) is
       pragma Warnings (Off, C);
-
    begin
       null;
    end No_OP;
@@ -599,6 +607,19 @@ package body Sem_Case is
 
    package body Generic_Choices_Processing is
 
+      --  The following type is used to gather the entries for the choice
+      --  table, so that we can then allocate the right length.
+
+      type Link;
+      type Link_Ptr is access all Link;
+
+      type Link is record
+         Val : Choice_Bounds;
+         Nxt : Link_Ptr;
+      end record;
+
+      procedure Free is new Ada.Unchecked_Deallocation (Link, Link_Ptr);
+
       ---------------------
       -- Analyze_Choices --
       ---------------------
@@ -606,20 +627,19 @@ package body Sem_Case is
       procedure Analyze_Choices
         (N              : Node_Id;
          Subtyp         : Entity_Id;
-         Choice_Table   : out Choice_Table_Type;
-         Last_Choice    : out Nat;
          Raises_CE      : out Boolean;
          Others_Present : out Boolean)
       is
-         pragma Assert (Choice_Table'First = 1);
-
          E : Entity_Id;
 
          Enode : Node_Id;
          --  This is where we post error messages for bounds out of range
 
-         Nb_Choices        : constant Nat := Choice_Table'Length;
-         Sort_Choice_Table : Sort_Choice_Table_Type (0 .. Nb_Choices);
+         Choice_List : Link_Ptr := null;
+         --  Gather list of choices
+
+         Num_Choices : Nat := 0;
+         --  Number of entries in Choice_List
 
          Choice_Type : constant Entity_Id := Base_Type (Subtyp);
          --  The actual type against which the discrete choices are resolved.
@@ -648,13 +668,17 @@ package body Sem_Case is
          Kind   : Node_Kind;
          --  The node kind of the current Choice
 
+         Delete_Choice : Boolean;
+         --  Set to True to delete the current choice
+
          Others_Choice : Node_Id := Empty;
          --  Remember others choice if it is present (empty otherwise)
 
          procedure Check (Choice : Node_Id; Lo, Hi : Node_Id);
          --  Checks the validity of the bounds of a choice. When the bounds
-         --  are static and no error occurred the bounds are entered into the
-         --  choices table so that they can be sorted later on.
+         --  are static and no error occurred the bounds are collected for
+         --  later entry into the choices table so that they can be sorted
+         --  later on.
 
          -----------
          -- Check --
@@ -706,8 +730,7 @@ package body Sem_Case is
 
                --  If the choice is an entity name, then it is a type, and we
                --  want to post the message on the reference to this entity.
-               --  Otherwise we want to post it on the lower bound of the
-               --  range.
+               --  Otherwise post it on the lower bound of the range.
 
                if Is_Entity_Name (Choice) then
                   Enode := Choice;
@@ -751,22 +774,20 @@ package body Sem_Case is
                end if;
             end if;
 
-            --  Store bounds in the table
+            --  Collect bounds in the list
 
             --  Note: we still store the bounds, even if they are out of range,
             --  since this may prevent unnecessary cascaded errors for values
             --  that are covered by such an excessive range.
 
-            Last_Choice := Last_Choice + 1;
-            Sort_Choice_Table (Last_Choice).Lo   := Lo;
-            Sort_Choice_Table (Last_Choice).Hi   := Hi;
-            Sort_Choice_Table (Last_Choice).Node := Choice;
+            Choice_List :=
+              new Link'(Val => (Lo, Hi, Choice), Nxt => Choice_List);
+            Num_Choices := Num_Choices + 1;
          end Check;
 
       --  Start of processing for Analyze_Choices
 
       begin
-         Last_Choice    := 0;
          Raises_CE      := False;
          Others_Present := False;
 
@@ -811,6 +832,7 @@ package body Sem_Case is
             else
                Choice := First (Get_Choices (Alt));
                while Present (Choice) loop
+                  Delete_Choice := False;
                   Analyze (Choice);
                   Kind := Nkind (Choice);
 
@@ -834,7 +856,45 @@ package body Sem_Case is
                      else
                         E := Entity (Choice);
 
-                        if not Is_Static_Subtype (E) then
+                        --  Case of predicated subtype
+
+                        if Has_Predicates (E) then
+
+                           --  Use of non-static predicate is an error
+
+                           if not Is_Discrete_Type (E)
+                             or else No (Static_Predicate (E))
+                           then
+                              Bad_Predicated_Subtype_Use
+                                (E, N,
+                                 "cannot use subtype&  with non-static "
+                                 & "predicate as case alternative");
+
+                              --  Static predicate case
+
+                           else
+                              declare
+                                 Copy : constant List_Id := Empty_List;
+                                 P    : Node_Id;
+                                 C    : Node_Id;
+
+                              begin
+                                 P := First (Static_Predicate (E));
+                                 while Present (P) loop
+                                    C := New_Copy (P);
+                                    Set_Sloc (C, Sloc (Choice));
+                                    Append_To (Copy, C);
+                                    Next (P);
+                                 end loop;
+
+                                 Insert_List_After (Choice, Copy);
+                                 Delete_Choice := True;
+                              end;
+                           end if;
+
+                        --  Not predicated subtype case
+
+                        elsif not Is_Static_Subtype (E) then
                            Process_Non_Static_Choice (Choice);
                         else
                            Check
@@ -848,6 +908,8 @@ package body Sem_Case is
                      Resolve_Discrete_Subtype_Indication
                        (Choice, Expected_Type);
 
+                     --  Here for other than predicated subtype case
+
                      if Etype (Choice) /= Any_Type then
                         declare
                            C : constant Node_Id := Constraint (Choice);
@@ -911,7 +973,18 @@ package body Sem_Case is
                      Check (Choice, Choice, Choice);
                   end if;
 
-                  Next (Choice);
+                  --  Move to next choice, deleting the current one if the
+                  --  flag requesting this deletion is set True.
+
+                  declare
+                     C : constant Node_Id := Choice;
+                  begin
+                     Next (Choice);
+
+                     if Delete_Choice then
+                        Remove (C);
+                     end if;
+                  end;
                end loop;
 
                Process_Associated_Node (Alt);
@@ -920,66 +993,48 @@ package body Sem_Case is
             Next (Alt);
          end loop;
 
-         Check_Choices
-           (Sort_Choice_Table (0 .. Last_Choice),
-            Bounds_Type,
-            Subtyp,
-            Others_Present or else (Choice_Type = Universal_Integer),
-            N);
-
-         --  Now copy the sorted discrete choices
-
-         for J in 1 .. Last_Choice loop
-            Choice_Table (Choice_Table'First - 1 + J) := Sort_Choice_Table (J);
-         end loop;
+         --  Now we can create the Choice_Table, since we know how long
+         --  it needs to be so we can allocate exactly the right length.
 
-         --  If no others choice we are all done, otherwise we have one more
-         --  step, which is to set the Others_Discrete_Choices field of the
-         --  others choice (to contain all otherwise unspecified choices).
-         --  Skip this if CE is known to be raised.
+         declare
+            Choice_Table : Choice_Table_Type (0 .. Num_Choices);
 
-         if Others_Present and not Raises_CE then
-            Expand_Others_Choice
-              (Case_Table    => Choice_Table (1 .. Last_Choice),
-               Others_Choice => Others_Choice,
-               Choice_Type   => Bounds_Type);
-         end if;
+         begin
+            --  Now copy the items we collected in the linked list into this
+            --  newly allocated table (leave entry 0 unused for sorting).
+
+            declare
+               T : Link_Ptr;
+            begin
+               for J in 1 .. Num_Choices loop
+                  T := Choice_List;
+                  Choice_List := T.Nxt;
+                  Choice_Table (J) := T.Val;
+                  Free (T);
+               end loop;
+            end;
+
+            Check_Choices
+              (Choice_Table,
+               Bounds_Type,
+               Subtyp,
+               Others_Present or else (Choice_Type = Universal_Integer),
+               N);
+
+            --  If no others choice we are all done, otherwise we have one more
+            --  step, which is to set the Others_Discrete_Choices field of the
+            --  others choice (to contain all otherwise unspecified choices).
+            --  Skip this if CE is known to be raised.
+
+            if Others_Present and not Raises_CE then
+               Expand_Others_Choice
+                 (Case_Table    => Choice_Table,
+                  Others_Choice => Others_Choice,
+                  Choice_Type   => Bounds_Type);
+            end if;
+         end;
       end Analyze_Choices;
 
-      -----------------------
-      -- Number_Of_Choices --
-      -----------------------
-
-      function Number_Of_Choices (N : Node_Id) return Nat is
-         Alt : Node_Id;
-         --  A case statement alternative or a record variant
-
-         Choice : Node_Id;
-         Count  : Nat := 0;
-
-      begin
-         if No (Get_Alternatives (N)) then
-            return 0;
-         end if;
-
-         Alt := First_Non_Pragma (Get_Alternatives (N));
-         while Present (Alt) loop
-
-            Choice := First (Get_Choices (Alt));
-            while Present (Choice) loop
-               if Nkind (Choice) /= N_Others_Choice then
-                  Count := Count + 1;
-               end if;
-
-               Next (Choice);
-            end loop;
-
-            Next_Non_Pragma (Alt);
-         end loop;
-
-         return Count;
-      end Number_Of_Choices;
-
    end Generic_Choices_Processing;
 
 end Sem_Case;
diff --git a/gcc/ada/sem_case.ads b/gcc/ada/sem_case.ads
index 78ae7c61b3b..ccee41f02a9 100644
--- a/gcc/ada/sem_case.ads
+++ b/gcc/ada/sem_case.ads
@@ -34,16 +34,6 @@ with Types; use Types;
 
 package Sem_Case is
 
-   type Choice_Bounds is record
-     Lo   : Node_Id;
-     Hi   : Node_Id;
-     Node : Node_Id;
-   end record;
-
-   type Choice_Table_Type is array (Pos range <>) of Choice_Bounds;
-   --  Table type used to sort the choices present in a case statement,
-   --  array aggregate or record variant.
-
    procedure No_OP (C : Node_Id);
    --  The no-operation routine. Does absolutely nothing. Can be used
    --  in the following generic for the parameter Process_Empty_Choice.
@@ -75,16 +65,9 @@ package Sem_Case is
 
    package Generic_Choices_Processing is
 
-      function Number_Of_Choices (N : Node_Id) return Nat;
-      --  Iterates through the choices of N, (N can be a case expression, case
-      --  statement, array aggregate or record variant), counting all the
-      --  Choice nodes except for the Others choice.
-
       procedure Analyze_Choices
         (N              : Node_Id;
          Subtyp         : Entity_Id;
-         Choice_Table   : out Choice_Table_Type;
-         Last_Choice    : out Nat;
          Raises_CE      : out Boolean;
          Others_Present : out Boolean);
       --  From a case expression, case statement, array aggregate or record
@@ -92,23 +75,6 @@ package Sem_Case is
       --  choices. Subtyp is the subtype of the discrete choices. The type
       --  against which the discrete choices must be resolved is its base type.
       --
-      --  On entry Choice_Table must be big enough to contain all the discrete
-      --  choices encountered. The lower bound of Choice_Table must be one.
-      --
-      --  On exit Choice_Table contains all the static and non empty discrete
-      --  choices in sorted order. Last_Choice gives the position of the last
-      --  valid choice in Choice_Table, Choice_Table'First contains the first.
-      --  We can have Last_Choice < Choice_Table'Last for one (or several) of
-      --  the following reasons:
-      --
-      --    (a) The list of choices contained a non static choice
-      --
-      --    (b) The list of choices contained an empty choice
-      --        (something like "1 .. 0 => ")
-      --
-      --    (c) One of the bounds of a discrete choice contains an
-      --        error or raises constraint error.
-      --
       --  In one of the bounds of a discrete choice raises a constraint
       --  error the flag Raise_CE is set.
       --
diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb
index 58150a32893..909fe8f1ceb 100644
--- a/gcc/ada/sem_ch13.adb
+++ b/gcc/ada/sem_ch13.adb
@@ -77,6 +77,23 @@ package body Sem_Ch13 is
    --  inherited from a derived type that is no longer appropriate for the
    --  new Esize value. In this case, we reset the Alignment to unknown.
 
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Build_Predicate_Function
+     (Typ   : Entity_Id;
+      FDecl : out Node_Id;
+      FBody : out Node_Id);
+   --  If Typ has predicates (indicated by Has_Predicates being set for Typ,
+   --  then either there are pragma Invariant entries on the rep chain for the
+   --  type (note that Predicate aspects are converted to pragam Predicate), or
+   --  there are inherited aspects from a parent type, or ancestor subtypes,
+   --  or interfaces. This procedure builds the spec and body for the Predicate
+   --  function that tests these predicates, returning them in PDecl and Pbody
+   --  and setting Predicate_Procedure for Typ. In some error situations no
+   --  procedure is built, in which case PDecl/PBody are empty on return.
+
    function Get_Alignment_Value (Expr : Node_Id) return Uint;
    --  Given the expression for an alignment value, returns the corresponding
    --  Uint value. If the value is inappropriate, then error messages are
@@ -3038,6 +3055,23 @@ package body Sem_Ch13 is
       end if;
 
       Inside_Freezing_Actions := Inside_Freezing_Actions - 1;
+
+      --  If we have a type with predicates, build predicate function
+
+      if Is_Type (E) and then Has_Predicates (E) then
+         declare
+            FDecl : Node_Id;
+            FBody : Node_Id;
+
+         begin
+            Build_Predicate_Function (E, FDecl, FBody);
+
+            if Present (FDecl) then
+               Insert_After (N, FBody);
+               Insert_After (N, FDecl);
+            end if;
+         end;
+      end if;
    end Analyze_Freeze_Entity;
 
    ------------------------------------------
@@ -3773,6 +3807,605 @@ package body Sem_Ch13 is
       end if;
    end Build_Invariant_Procedure;
 
+   ------------------------------
+   -- Build_Predicate_Function --
+   ------------------------------
+
+   --  The procedure that is constructed here has the form
+
+   --  function typPredicate (Ixxx : typ) return Boolean is
+   --  begin
+   --     return
+   --        exp1 and then exp2 and then ...
+   --        and then typ1Predicate (typ1 (Ixxx))
+   --        and then typ2Predicate (typ2 (Ixxx))
+   --        and then ...;
+   --  end typPredicate;
+
+   --  Here exp1, and exp2 are expressions from Predicate pragmas. Note that
+   --  this is the point at which these expressions get analyzed, providing the
+   --  required delay, and typ1, typ2, are entities from which predicates are
+   --  inherited. Note that we do NOT generate Check pragmas, that's because we
+   --  use this function even if checks are off, e.g. for membership tests.
+
+   procedure Build_Predicate_Function
+     (Typ   : Entity_Id;
+      FDecl : out Node_Id;
+      FBody : out Node_Id)
+   is
+      Loc  : constant Source_Ptr := Sloc (Typ);
+      Spec : Node_Id;
+      SId  : Entity_Id;
+
+      Expr : Node_Id;
+      --  This is the expression for the return statement in the function. It
+      --  is build by connecting the component predicates with AND THEN.
+
+      procedure Add_Call (T : Entity_Id);
+      --  Includes a call to the predicate function for type T in Expr if T
+      --  has predicates and Predicate_Function (T) is non-empty.
+
+      procedure Add_Predicates;
+      --  Appends expressions for any Predicate pragmas in the rep item chain
+      --  Typ to Expr. Note that we look only at items for this exact entity.
+      --  Inheritance of predicates for the parent type is done by calling the
+      --  Predicate_Function of the parent type, using Add_Call above.
+
+      procedure Build_Static_Predicate;
+      --  This function is called to process a static predicate, and put it in
+      --  canonical form and store it in Static_Predicate (Typ).
+
+      Object_Name : constant Name_Id := New_Internal_Name ('I');
+      --  Name for argument of Predicate procedure
+
+      --------------
+      -- Add_Call --
+      --------------
+
+      procedure Add_Call (T : Entity_Id) is
+         Exp : Node_Id;
+
+      begin
+         if Present (T) and then Present (Predicate_Function (T)) then
+            Set_Has_Predicates (Typ);
+
+            --  Build the call to the predicate function of T
+
+            Exp :=
+              Make_Predicate_Call
+                (T,
+                 Convert_To (T,
+                   Make_Identifier (Loc, Chars => Object_Name)));
+
+            --  Add call to evolving expression, using AND THEN if needed
+
+            if No (Expr) then
+               Expr := Exp;
+            else
+               Expr :=
+                 Make_And_Then (Loc,
+                   Left_Opnd  => Relocate_Node (Expr),
+                   Right_Opnd => Exp);
+            end if;
+
+            --  Output info message on inheritance if required
+
+            if Opt.List_Inherited_Aspects then
+               Error_Msg_Sloc := Sloc (Predicate_Function (T));
+               Error_Msg_Node_2 := T;
+               Error_Msg_N ("?info: & inherits predicate from & #", Typ);
+            end if;
+         end if;
+      end Add_Call;
+
+      --------------------
+      -- Add_Predicates --
+      --------------------
+
+      procedure Add_Predicates is
+         Ritem : Node_Id;
+         Arg1  : Node_Id;
+         Arg2  : Node_Id;
+
+         function Replace_Node (N : Node_Id) return Traverse_Result;
+         --  Process single node for traversal to replace type references
+
+         procedure Replace_Type is new Traverse_Proc (Replace_Node);
+         --  Traverse an expression changing every occurrence of an entity
+         --  reference to type T with a reference to the object argument.
+
+         ------------------
+         -- Replace_Node --
+         ------------------
+
+         function Replace_Node (N : Node_Id) return Traverse_Result is
+         begin
+            --  Case of entity name referencing the type
+
+            if Is_Entity_Name (N) and then Entity (N) = Typ then
+
+               --  Replace with object
+
+               Rewrite (N,
+                 Make_Identifier (Loc,
+                   Chars => Object_Name));
+
+               --  All done with this node
+
+               return Skip;
+
+            --  Not an occurrence of the type entity, keep going
+
+            else
+               return OK;
+            end if;
+         end Replace_Node;
+
+      --  Start of processing for Add_Predicates
+
+      begin
+         Ritem := First_Rep_Item (Typ);
+         while Present (Ritem) loop
+            if Nkind (Ritem) = N_Pragma
+              and then Pragma_Name (Ritem) = Name_Predicate
+            then
+               Arg1 := First (Pragma_Argument_Associations (Ritem));
+               Arg2 := Next (Arg1);
+
+               Arg1 := Get_Pragma_Arg (Arg1);
+               Arg2 := Get_Pragma_Arg (Arg2);
+
+               --  See if this predicate pragma is for the current type
+
+               if Entity (Arg1) = Typ then
+
+                  --  We have a match, this entry is for our subtype
+
+                  --  First We need to replace any occurrences of the name of
+                  --  the type with references to the object. We do this by
+                  --  first doing a preanalysis, to identify all the entities,
+                  --  then we traverse looking for the type entity, doing the
+                  --  needed substitution. The preanalysis is done with the
+                  --  special OK_To_Reference flag set on the type, so that if
+                  --  we get an occurrence of this type, it will be recognized
+                  --  as legitimate.
+
+                  Set_OK_To_Reference (Typ, True);
+                  Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
+                  Set_OK_To_Reference (Typ, False);
+                  Replace_Type (Arg2);
+
+                  --  OK, replacement complete, now we can add the expression
+
+                  if No (Expr) then
+                     Expr := Relocate_Node (Arg2);
+
+                  --  There already was a predicate, so add to it
+
+                  else
+                     Expr :=
+                       Make_And_Then (Loc,
+                         Left_Opnd  => Relocate_Node (Expr),
+                         Right_Opnd => Relocate_Node (Arg2));
+                  end if;
+               end if;
+            end if;
+
+            Next_Rep_Item (Ritem);
+         end loop;
+      end Add_Predicates;
+
+      ----------------------------
+      -- Build_Static_Predicate --
+      ----------------------------
+
+      procedure Build_Static_Predicate is
+         Exp : Node_Id;
+         Alt : Node_Id;
+
+         Non_Static : Boolean := False;
+         --  Set True if something non-static is found
+
+         Plist : List_Id := No_List;
+         --  The entries in Plist are either static expressions which represent
+         --  a possible value, or ranges of values. Subtype marks don't appear,
+         --  since we expand them out.
+
+         Lo, Hi : Uint;
+         --  Low bound and high bound values of static subtype of Typ
+
+         procedure Process_Entry (N : Node_Id);
+         --  Process one entry (range or value or subtype mark)
+
+         -------------------
+         -- Process_Entry --
+         -------------------
+
+         procedure Process_Entry (N : Node_Id) is
+            SLo, SHi : Uint;
+            --  Low and high bounds of range in list
+
+            P : Node_Id;
+
+            function Build_Val (V : Uint) return Node_Id;
+            --  Return an analyzed N_Identifier node referencing this value
+
+            function Build_Range (Lo, Hi : Uint) return Node_Id;
+            --  Return an analyzed N_Range node referencing this range
+
+            function Lo_Val (N : Node_Id) return Uint;
+            --  Given static expression or static range, gets expression value
+            --  or low bound of range.
+
+            function Hi_Val (N : Node_Id) return Uint;
+            --  Given static expression or static range, gets expression value
+            --  of high bound of range.
+
+            -----------------
+            -- Build_Range --
+            -----------------
+
+            function Build_Range (Lo, Hi : Uint) return Node_Id is
+               Result : Node_Id;
+            begin
+               if Lo = Hi then
+                  return Build_Val (Hi);
+               else
+                  Result :=
+                    Make_Range (Sloc (N),
+                      Low_Bound  => Build_Val (Lo),
+                      High_Bound => Build_Val (Hi));
+                  Set_Etype (Result, Typ);
+                  Set_Analyzed (Result);
+                  return Result;
+               end if;
+            end Build_Range;
+
+            ---------------
+            -- Build_Val --
+            ---------------
+
+            function Build_Val (V : Uint) return Node_Id is
+               Result : Node_Id;
+
+            begin
+               if Is_Enumeration_Type (Typ) then
+                  Result := Get_Enum_Lit_From_Pos (Typ, V, Sloc (N));
+               else
+                  Result := Make_Integer_Literal (Sloc (N), Intval => V);
+               end if;
+
+               Set_Etype (Result, Typ);
+               Set_Is_Static_Expression (Result);
+               Set_Analyzed (Result);
+               return Result;
+            end Build_Val;
+
+            ------------
+            -- Hi_Val --
+            ------------
+
+            function Hi_Val (N : Node_Id) return Uint is
+            begin
+               if Nkind (N) = N_Identifier then
+                  return Expr_Value (N);
+               else
+                  return Expr_Value (High_Bound (N));
+               end if;
+            end Hi_Val;
+
+            ------------
+            -- Lo_Val --
+            ------------
+
+            function Lo_Val (N : Node_Id) return Uint is
+            begin
+               if Nkind (N) = N_Identifier then
+                  return Expr_Value (N);
+               else
+                  return Expr_Value (Low_Bound (N));
+               end if;
+            end Lo_Val;
+
+         --  Start of processing for Process_Entry
+
+         begin
+            --  Range case
+
+            if Nkind (N) = N_Range then
+               if not Is_Static_Expression (Low_Bound (N))
+                    or else
+                  not Is_Static_Expression (High_Bound (N))
+               then
+                  Non_Static := True;
+                  return;
+               else
+                  SLo := Lo_Val (N);
+                  SHi := Hi_Val (N);
+               end if;
+
+            --  Identifier case
+
+            else pragma Assert (Nkind (N) = N_Identifier);
+
+               --  Static expression case
+
+               if Is_Static_Expression (N) then
+                  SLo := Lo_Val (N);
+                  SHi := Hi_Val (N);
+
+               --  Type case
+
+               elsif Is_Type (Entity (N)) then
+
+                  --  If type has static predicates, process them recursively
+
+                  if Present (Static_Predicate (Entity (N))) then
+                     P := First (Static_Predicate (Entity (N)));
+                     while Present (P) loop
+                        Process_Entry (P);
+
+                        if Non_Static then
+                           return;
+                        else
+                           Next (P);
+                        end if;
+                     end loop;
+
+                     return;
+
+                  --  For static subtype without predicates, get range
+
+                  elsif Is_Static_Subtype (Entity (N))
+                    and then not Has_Predicates (Entity (N))
+                  then
+                     SLo := Expr_Value (Type_Low_Bound  (Entity (N)));
+                     SHi := Expr_Value (Type_High_Bound (Entity (N)));
+
+                  --  Any other type makes us non-static
+
+                  else
+                     Non_Static := True;
+                     return;
+                  end if;
+
+               --  Any other kind of identifier in predicate (e.g. a non-static
+               --  expression value) means this is not a static predicate.
+
+               else
+                  Non_Static := True;
+                  return;
+               end if;
+            end if;
+
+            --  Here with SLo and SHi set for (possibly single element) range
+            --  of entry to insert in Plist. Non-static if out of range.
+
+            if SLo < Lo or else SHi > Hi then
+               Non_Static := True;
+               return;
+            end if;
+
+            --  If no Plist currently, create it
+
+            if No (Plist) then
+               Plist := New_List (Build_Range (SLo, SHi));
+               return;
+
+            --  Otherwise search Plist for insertion point
+
+            else
+               P := First (Plist);
+               loop
+                  --  Case of inserting before current entry
+
+                  if SHi < Lo_Val (P) - 1 then
+                     Insert_Before (P, Build_Range (SLo, SHi));
+                     exit;
+
+                  --  Case of belongs past current entry
+
+                  elsif SLo > Hi_Val (P) + 1 then
+
+                     --  End of list case
+
+                     if No (Next (P)) then
+                        Append_To (Plist, Build_Range (SLo, SHi));
+                        exit;
+
+                     --  Else just move to next item on list
+
+                     else
+                        Next (P);
+                     end if;
+
+                  --  Case of extending current entyr, and in overlap cases
+                  --  may also eat up entries past this one.
+
+                  else
+                     declare
+                        New_Lo : constant Uint := UI_Min (Lo_Val (P), SLo);
+                        New_Hi : Uint          := UI_Max (Hi_Val (P), SHi);
+
+                     begin
+                        --  See if there are entries past us that we eat up
+
+                        while Present (Next (P))
+                          and then Lo_Val (Next (P)) <= New_Hi + 1
+                        loop
+                           New_Hi := Hi_Val (Next (P));
+                           Remove (Next (P));
+                        end loop;
+
+                        --  We now need to replace the current node P with
+                        --  a new entry New_Lo .. New_Hi.
+
+                        Insert_After (P, Build_Range (New_Lo, New_Hi));
+                        Remove (P);
+                        exit;
+                     end;
+                  end if;
+               end loop;
+            end if;
+         end Process_Entry;
+
+      --  Start of processing for Build_Static_Predicate
+
+      begin
+         --  Immediately non-static if our subtype is non static, or we
+         --  do not have an appropriate discrete subtype in the first place.
+
+         if not Ekind_In (Typ, E_Enumeration_Subtype,
+                               E_Modular_Integer_Subtype,
+                               E_Signed_Integer_Subtype)
+           or else not Is_Static_Subtype (Typ)
+         then
+            return;
+         end if;
+
+         Lo := Expr_Value (Type_Low_Bound  (Typ));
+         Hi := Expr_Value (Type_High_Bound (Typ));
+
+         --  Check if we have membership predicate
+
+         if Nkind (Expr) = N_In then
+            Exp := Expr;
+
+         --  Allow qualified expression with membership predicate inside
+
+         elsif Nkind (Expr) = N_Qualified_Expression
+           and then Nkind (Expression (Expr)) = N_In
+         then
+            Exp := Expression (Expr);
+
+         --  Anything else cannot be a static predicate
+
+         else
+            return;
+         end if;
+
+         --  We have a membership operation, so we have a potentially static
+         --  predicate, collect and canonicalize the entries in the list.
+
+         if Present (Right_Opnd (Exp)) then
+            Process_Entry (Right_Opnd (Exp));
+
+            if Non_Static then
+               return;
+            end if;
+
+         else
+            Alt := First (Alternatives (Exp));
+            while Present (Alt) loop
+               Process_Entry (Alt);
+
+               if Non_Static then
+                  return;
+               end if;
+
+               Next (Alt);
+            end loop;
+         end if;
+
+         --  Processing was successful and all entries were static, so
+         --  now we can store the result as the predicate list.
+
+         Set_Static_Predicate (Typ, Plist);
+      end Build_Static_Predicate;
+
+   --  Start of processing for Build_Predicate_Function
+
+   begin
+      --  Initialize for construction of statement list
+
+      Expr  := Empty;
+      FDecl := Empty;
+      FBody := Empty;
+
+      --  Return if already built or if type does not have predicates
+
+      if not Has_Predicates (Typ)
+        or else Present (Predicate_Function (Typ))
+      then
+         return;
+      end if;
+
+      --  Add Predicates for the current type
+
+      Add_Predicates;
+
+      --  Add predicates for ancestor if present
+
+      declare
+         Atyp : constant Entity_Id := Nearest_Ancestor (Typ);
+      begin
+         if Present (Atyp) then
+            Add_Call (Atyp);
+         end if;
+      end;
+
+      --  If we have predicates, build the function
+
+      if Present (Expr) then
+
+         --  Deal with static predicate case
+
+         Build_Static_Predicate;
+
+         --  Build function declaration
+
+         pragma Assert (Has_Predicates (Typ));
+         SId :=
+           Make_Defining_Identifier (Loc,
+             Chars => New_External_Name (Chars (Typ), "Predicate"));
+         Set_Has_Predicates (SId);
+         Set_Predicate_Function (Typ, SId);
+
+         Spec :=
+           Make_Function_Specification (Loc,
+             Defining_Unit_Name       => SId,
+             Parameter_Specifications => New_List (
+               Make_Parameter_Specification (Loc,
+                 Defining_Identifier =>
+                   Make_Defining_Identifier (Loc, Chars => Object_Name),
+                 Parameter_Type      => New_Occurrence_Of (Typ, Loc))),
+             Result_Definition        =>
+               New_Occurrence_Of (Standard_Boolean, Loc));
+
+         FDecl :=
+           Make_Subprogram_Declaration (Loc,
+             Specification => Spec);
+
+         --  Build function body
+
+         SId :=
+           Make_Defining_Identifier (Loc,
+             Chars => New_External_Name (Chars (Typ), "Predicate"));
+
+         Spec :=
+           Make_Function_Specification (Loc,
+             Defining_Unit_Name       => SId,
+             Parameter_Specifications => New_List (
+               Make_Parameter_Specification (Loc,
+                 Defining_Identifier =>
+                   Make_Defining_Identifier (Loc, Chars => Object_Name),
+                 Parameter_Type =>
+                   New_Occurrence_Of (Typ, Loc))),
+             Result_Definition        =>
+               New_Occurrence_Of (Standard_Boolean, Loc));
+
+         FBody :=
+           Make_Subprogram_Body (Loc,
+             Specification              => Spec,
+             Declarations               => Empty_List,
+             Handled_Statement_Sequence =>
+               Make_Handled_Sequence_Of_Statements (Loc,
+                 Statements => New_List (
+                   Make_Simple_Return_Statement (Loc,
+                     Expression => Expr))));
+      end if;
+   end Build_Predicate_Function;
+
    -----------------------------------
    -- Check_Constant_Address_Clause --
    -----------------------------------
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 5322387c3a4..9371952fd5e 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/gcc/ada/sem_ch3.adb
@@ -3842,7 +3842,14 @@ package body Sem_Ch3 is
       Set_Is_Ada_2005_Only  (Id, Is_Ada_2005_Only  (T));
       Set_Is_Ada_2012_Only  (Id, Is_Ada_2012_Only  (T));
       Set_Convention        (Id, Convention        (T));
-      Set_Has_Predicates    (Id, Has_Predicates    (T));
+
+      --  If ancestor has predicates then so does the subtype, and in addition
+      --  we must delay the freeze to properly arrange predicate inheritance.
+
+      if Has_Predicates (T) then
+         Set_Has_Predicates (Id);
+         Set_Has_Delayed_Freeze (Id);
+      end if;
 
       --  In the case where there is no constraint given in the subtype
       --  indication, Process_Subtype just returns the Subtype_Mark, so its
@@ -4292,13 +4299,9 @@ package body Sem_Ch3 is
       Discr_Name : Node_Id;
       Discr_Type : Entity_Id;
 
-      Case_Table     : Choice_Table_Type (1 .. Number_Of_Choices (N));
-      Last_Choice    : Nat;
       Dont_Care      : Boolean;
       Others_Present : Boolean := False;
 
-      pragma Warnings (Off, Case_Table);
-      pragma Warnings (Off, Last_Choice);
       pragma Warnings (Off, Dont_Care);
       pragma Warnings (Off, Others_Present);
       --  We don't care about the assigned values of any of these
@@ -4332,8 +4335,7 @@ package body Sem_Ch3 is
 
       --  Call the instantiated Analyze_Choices which does the rest of the work
 
-      Analyze_Choices
-        (N, Discr_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
+      Analyze_Choices (N, Discr_Type, Dont_Care, Others_Present);
    end Analyze_Variant_Part;
 
    ----------------------------
diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb
index ac3fa0351e4..45a4a218d6c 100644
--- a/gcc/ada/sem_ch4.adb
+++ b/gcc/ada/sem_ch4.adb
@@ -1137,7 +1137,6 @@ package body Sem_Ch4 is
       Exp_Type  : Entity_Id;
       Exp_Btype : Entity_Id;
 
-      Last_Choice    : Nat;
       Dont_Care      : Boolean;
       Others_Present : Boolean;
 
@@ -1154,8 +1153,6 @@ package body Sem_Ch4 is
            Process_Associated_Node   => No_OP);
       use Case_Choices_Processing;
 
-      Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
-
       -----------------------------
       -- Non_Static_Choice_Error --
       -----------------------------
@@ -1252,8 +1249,7 @@ package body Sem_Ch4 is
 
       --  Call instantiated Analyze_Choices which does the rest of the work
 
-      Analyze_Choices
-        (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
+      Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
 
       if Exp_Type = Universal_Integer and then not Others_Present then
          Error_Msg_N
@@ -5563,6 +5559,13 @@ package body Sem_Ch4 is
          return False;
       end if;
 
+      --  If OK_To_Reference is set for the entity, then don't complain, it
+      --  means we are doing a preanalysis in which such complaints are wrong.
+
+      if OK_To_Reference (Entity (Enode)) then
+         return False;
+      end if;
+
       --  Now test the entity we got to see if it is a bad case
 
       case Ekind (Entity (Enode)) is
diff --git a/gcc/ada/sem_ch5.adb b/gcc/ada/sem_ch5.adb
index 692b1798edd..79ff1d2e68b 100644
--- a/gcc/ada/sem_ch5.adb
+++ b/gcc/ada/sem_ch5.adb
@@ -1018,12 +1018,6 @@ package body Sem_Ch5 is
          Analyze_Statements (Statements (Alternative));
       end Process_Statements;
 
-      --  Table to record choices. Put after subprograms since we make
-      --  a call to Number_Of_Choices to get the right number of entries.
-
-      Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
-      pragma Warnings (Off, Case_Table);
-
    --  Start of processing for Analyze_Case_Statement
 
    begin
@@ -1096,8 +1090,7 @@ package body Sem_Ch5 is
 
       --  Call instantiated Analyze_Choices which does the rest of the work
 
-      Analyze_Choices
-        (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
+      Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
 
       if Exp_Type = Universal_Integer and then not Others_Present then
          Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 4861fdcabda..ed34826646c 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -329,6 +329,30 @@ package body Sem_Util is
       end if;
    end Apply_Compile_Time_Constraint_Error;
 
+   --------------------------------
+   -- Bad_Predicated_Subtype_Use --
+   --------------------------------
+
+   procedure Bad_Predicated_Subtype_Use
+     (Typ : Entity_Id;
+      N   : Node_Id;
+      Msg : String)
+   is
+   begin
+      if Has_Predicates (Typ) then
+         if Is_Generic_Actual_Type (Typ) then
+            Error_Msg_F (Msg & '?', Typ);
+            Error_Msg_F ("\Program_Error will be raised at run time?", Typ);
+            Insert_Action (N,
+              Make_Raise_Program_Error (Sloc (N),
+                Reason => PE_Bad_Predicated_Generic_Type));
+
+         else
+            Error_Msg_F (Msg, Typ);
+         end if;
+      end if;
+   end Bad_Predicated_Subtype_Use;
+
    --------------------------
    -- Build_Actual_Subtype --
    --------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 928d8bf958d..4031b243c4a 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -93,6 +93,20 @@ package Sem_Util is
    --  not end with a ? (this is used when the caller wants to parameterize
    --  whether an error or warning is given.
 
+   procedure Bad_Predicated_Subtype_Use
+     (Typ : Entity_Id;
+      N   : Node_Id;
+      Msg : String);
+   --  This is called when Typ, a predicated subtype, is used in a context
+   --  which does not allow the use of a predicated subtype. Msg will be
+   --  passed to Error_Msg_F to output an appropriate message. The caller
+   --  should set up any insertions other than the & for the type itself.
+   --  Note that if Typ is a generic actual type, then the message will be
+   --  output as a warning, and a raise Program_Error is inserted using
+   --  Insert_Action with node N as the insertion point. Node N also supplies
+   --  the source location for construction of the raise node. If Typ is NOT a
+   --  type with predicates this call has no effect.
+
    function Build_Actual_Subtype
      (T : Entity_Id;
       N : Node_Or_Entity_Id) return Node_Id;
diff --git a/gcc/ada/types.ads b/gcc/ada/types.ads
index 6e496ddc328..ee2966c86a7 100644
--- a/gcc/ada/types.ads
+++ b/gcc/ada/types.ads
@@ -789,7 +789,7 @@ package Types is
       PE_Accessibility_Check_Failed,     -- 15
       PE_Address_Of_Intrinsic,           -- 16
       PE_All_Guards_Closed,              -- 17
-      PE_Bad_Attribute_For_Predicate,    -- 18
+      PE_Bad_Predicated_Generic_Type,    -- 18
       PE_Current_Task_In_Entry_Body,     -- 19
       PE_Duplicated_Entry_Address,       -- 20
       PE_Explicit_Raise,                 -- 21