einfo.ads, einfo.adb: Add handling of predicates.

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

	* einfo.ads, einfo.adb: Add handling of predicates.
	Rework handling of invariants.
	* exp_ch3.adb, exp_ch4.adb, exp_util.adb, sem_ch6.adb: Minor changes to
	handing of invariants.
	* par-prag.adb: Add dummy entry for pragma Predicate
	* sem_ch13.adb (Analyze_Aspect_Specifications): Add processing for
	Predicate aspects.
	* sem_prag.adb: Add implementation of pragma Predicate.
	* snames.ads-tmpl: Add entries for pragma Predicate.

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

	* elists.adb: Minor reformatting.

From-SVN: r165764

gcc/ada/ChangeLog

 2010-10-21  Robert Dewar  <dewar@adacore.com>
 
+	* einfo.ads, einfo.adb: Replace Predicate_Procedure by
+	Predicate_Functions.
+	* exp_ch4.adb (Expand_N_In): Handle predicates.
+	* exp_util.ads, exp_util.adb (Make_Predicate_Call): New function.
+	(Make_Predicate_Check): New function.
+	* freeze.adb (Freee_Entity): Build predicate function if needed.
+	* sem_ch13.adb (Build_Predicate_Function): New procedure.
+	(Analyze_Aspect_Specifications): No third argument for Predicate pragma
+	built from Predicate aspect.
+	* sem_ch13.ads (Build_Predicate_Function): New procedure.
+	* sem_ch3.adb: Add handling for predicates.
+	* sem_eval.adb (Eval_Membership_Op): Never static if predicate
+	functions around.
+	* sem_prag.adb (Analye_Pragma, case Predicate): Does not take a third
+	argument.
+
+2010-10-21  Robert Dewar  <dewar@adacore.com>
+
 	* einfo.ads, einfo.adb: Add handling of predicates.
 	Rework handling of invariants.
 	* exp_ch3.adb, exp_ch4.adb, exp_util.adb, sem_ch6.adb: Minor changes to

gcc/ada/einfo.adb

@@ -1411,7 +1411,7 @@ package body Einfo is
 
    function Has_Predicates (Id : E) return B is
    begin
-      pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure);
+      pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Function);
       return Flag250 (Id);
    end Has_Predicates;
 
@@ -3864,7 +3864,7 @@ package body Einfo is
    procedure Set_Has_Predicates (Id : E; V : B := True) is
    begin
       pragma Assert (Is_Type (Id)
-        or else Ekind (Id) = E_Procedure
+        or else Ekind (Id) = E_Function
         or else Ekind (Id) = E_Void);
       Set_Flag250 (Id, V);
    end Set_Has_Predicates;
@@ -6265,15 +6265,15 @@ package body Einfo is
         Ekind (Id) = E_Generic_Package;
    end Is_Package_Or_Generic_Package;
 
-   -------------------------
-   -- Predicate_Procedure --
-   -------------------------
+   ------------------------
+   -- Predicate_Function --
+   ------------------------
 
-   function Predicate_Procedure (Id : E) return E is
+   function Predicate_Function (Id : E) return E is
       S : Entity_Id;
 
    begin
-      pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
+      pragma Assert (Is_Type (Id));
 
       if No (Subprograms_For_Type (Id)) then
          return Empty;
@@ -6290,7 +6290,7 @@ package body Einfo is
 
          return Empty;
       end if;
-   end Predicate_Procedure;
+   end Predicate_Function;
 
    ---------------
    -- Is_Prival --
@@ -6860,11 +6860,11 @@ package body Einfo is
       Set_Subprograms_For_Type (Id, V);
    end Set_Invariant_Procedure;
 
-   -----------------------------
-   -- Set_Predicate_Procedure --
-   -----------------------------
+   ----------------------------
+   -- Set_Predicate_Function --
+   ----------------------------
 
-   procedure Set_Predicate_Procedure (Id : E; V : E) is
+   procedure Set_Predicate_Function (Id : E; V : E) is
       S : Entity_Id;
 
    begin
@@ -6882,7 +6882,7 @@ package body Einfo is
       end loop;
 
       Set_Subprograms_For_Type (Id, V);
-   end Set_Predicate_Procedure;
+   end Set_Predicate_Function;
 
    -----------------
    -- Size_Clause --

gcc/ada/einfo.ads

@@ -1677,7 +1677,7 @@ package Einfo is
 --       Present in type and subtype entities and in subprogram entities. Set
 --       if a pragma Predicate or Predicate aspect applies to the type, or if
 --       it inherits a Predicate aspect from its parent or progenitor types.
---       Also set in the predicate procedure entity, to distinguish it among
+--       Also set in the predicate function entity, to distinguish it among
 --       entries in the Subprograms_For_Type.
 
 --    Has_Primitive_Operations (Flag120) [base type only]
@@ -3276,13 +3276,12 @@ package Einfo is
 --       Direct_Primitive_Operations of its CRT; otherwise returns No_Elist.
 --       For all the other types returns the Direct_Primitive_Operations.
 
---    Predicate_Procedure (synthesized)
+--    Predicate_Function (synthesized)
 --       Present in all types. Set for types for which (Has_Predicates is True)
 --       and for which a predicate procedure has been built that tests that the
---       specified predicates are True. Contains the entity for the procedure
---       which takes a single argument of the given type, and returns if the
---       predicate holds, or raises exception Assertion_Error with an exception
---       message if it does not hold.
+--       specified predicates are True. Contains the entity for the function
+--       which takes a single argument of the given type, and returns True if
+--       the predicate holds and False if it does not.
 --
 --       Note: the reason this is marked as a synthesized attribute is that the
 --       way this is stored is as an element of the Subprograms_For_Type field.
@@ -3662,7 +3661,7 @@ package Einfo is
 --       entity. Basically this is a way of multiplexing the single field to
 --       hold more than one entity (since we ran out of space in some type
 --       entities). This is currently used for Invariant_Procedure and also
---       for Predicate_Procedure, and clients will always use the latter two
+--       for Predicate_Function, and clients will always use the latter two
 --       names to access entries in this list.
 
 --    Suppress_Elaboration_Warnings (Flag148)
@@ -4832,7 +4831,7 @@ package Einfo is
    --    Implementation_Base_Type            (synth)
    --    Invariant_Procedure                 (synth)
    --    Is_Access_Protected_Subprogram_Type (synth)
-   --    Predicate_Procedure                 (synth)
+   --    Predicate_Function                  (synth)
    --    Root_Type                           (synth)
    --    Size_Clause                         (synth)
 
@@ -6824,10 +6823,10 @@ package Einfo is
    ---------------------------------------------------
 
    function Invariant_Procedure                 (Id : E) return N;
-   function Predicate_Procedure                 (Id : E) return N;
+   function Predicate_Function                  (Id : E) return N;
 
    procedure Set_Invariant_Procedure            (Id : E; V : E);
-   procedure Set_Predicate_Procedure            (Id : E; V : E);
+   procedure Set_Predicate_Function             (Id : E; V : E);
 
    -----------------------------------
    -- Field Initialization Routines --

gcc/ada/exp_ch4.adb

@@ -4318,14 +4318,17 @@ package body Exp_Ch4 is
 
    procedure Expand_N_In (N : Node_Id) is
       Loc    : constant Source_Ptr := Sloc (N);
-      Rtyp   : constant Entity_Id  := Etype (N);
+      Restyp : constant Entity_Id  := Etype (N);
       Lop    : constant Node_Id    := Left_Opnd (N);
       Rop    : constant Node_Id    := Right_Opnd (N);
       Static : constant Boolean    := Is_OK_Static_Expression (N);
 
+      Ltyp  : Entity_Id;
+      Rtyp  : Entity_Id;
+
       procedure Expand_Set_Membership;
-      --  For each disjunct we create a simple equality or membership test.
-      --  The whole membership is rewritten as a short-circuit disjunction.
+      --  For each choice we create a simple equality or membership test.
+      --  The whole membership is rewritten connecting these with OR ELSE.
 
       ---------------------------
       -- Expand_Set_Membership --
@@ -4400,7 +4403,7 @@ package body Exp_Ch4 is
              Prefix         => Relocate_Node (Lop),
              Attribute_Name => Name_Valid));
 
-         Analyze_And_Resolve (N, Rtyp);
+         Analyze_And_Resolve (N, Restyp);
 
          Error_Msg_N ("?explicit membership test may be optimized away", N);
          Error_Msg_N -- CODEFIX
@@ -4411,24 +4414,32 @@ package body Exp_Ch4 is
    --  Start of processing for Expand_N_In
 
    begin
+      --  If set membersip case, expand with separate procedure
+
       if Present (Alternatives (N)) then
          Remove_Side_Effects (Lop);
          Expand_Set_Membership;
          return;
       end if;
 
+      --  Not set membership, proceed with expansion
+
+      Ltyp := Etype (Left_Opnd  (N));
+      Rtyp := Etype (Right_Opnd (N));
+
       --  Check case of explicit test for an expression in range of its
       --  subtype. This is suspicious usage and we replace it with a 'Valid
       --  test and give a warning. For floating point types however, this is a
       --  standard way to check for finite numbers, and using 'Valid would
       --  typically be a pessimization.
 
-      if Is_Scalar_Type (Etype (Lop))
-        and then not Is_Floating_Point_Type (Etype (Lop))
+      if Is_Scalar_Type (Ltyp)
+        and then not Is_Floating_Point_Type (Ltyp)
         and then Nkind (Rop) in N_Has_Entity
-        and then Etype (Lop) = Entity (Rop)
+        and then Ltyp = Entity (Rop)
         and then Comes_From_Source (N)
         and then VM_Target = No_VM
+        and then No (Predicate_Function (Rtyp))
       then
          Substitute_Valid_Check;
          return;
@@ -4448,8 +4459,6 @@ package body Exp_Ch4 is
             Lo : constant Node_Id := Low_Bound (Rop);
             Hi : constant Node_Id := High_Bound (Rop);
 
-            Ltyp : constant Entity_Id := Etype (Lop);
-
             Lo_Orig : constant Node_Id := Original_Node (Lo);
             Hi_Orig : constant Node_Id := Original_Node (Hi);
 
@@ -4493,7 +4502,7 @@ package body Exp_Ch4 is
               and then VM_Target = No_VM
             then
                Substitute_Valid_Check;
-               return;
+               goto Leave;
             end if;
 
             --  If bounds of type are known at compile time, and the end points
@@ -4517,7 +4526,7 @@ package body Exp_Ch4 is
               and then not In_Instance
             then
                Substitute_Valid_Check;
-               return;
+               goto Leave;
             end if;
 
             --  If we have an explicit range, do a bit of optimization based on
@@ -4537,10 +4546,9 @@ package body Exp_Ch4 is
                end if;
 
                Rewrite (N, New_Reference_To (Standard_False, Loc));
-               Analyze_And_Resolve (N, Rtyp);
+               Analyze_And_Resolve (N, Restyp);
                Set_Is_Static_Expression (N, Static);
-
-               return;
+               goto Leave;
 
             --  If both checks are known to succeed, replace result by True,
             --  since we know we are in range.
@@ -4552,10 +4560,9 @@ package body Exp_Ch4 is
                end if;
 
                Rewrite (N, New_Reference_To (Standard_True, Loc));
-               Analyze_And_Resolve (N, Rtyp);
+               Analyze_And_Resolve (N, Restyp);
                Set_Is_Static_Expression (N, Static);
-
-               return;
+               goto Leave;
 
             --  If lower bound check succeeds and upper bound check is not
             --  known to succeed or fail, then replace the range check with
@@ -4571,9 +4578,8 @@ package body Exp_Ch4 is
                  Make_Op_Le (Loc,
                    Left_Opnd  => Lop,
                    Right_Opnd => High_Bound (Rop)));
-               Analyze_And_Resolve (N, Rtyp);
-
-               return;
+               Analyze_And_Resolve (N, Restyp);
+               goto Leave;
 
             --  If upper bound check succeeds and lower bound check is not
             --  known to succeed or fail, then replace the range check with
@@ -4589,9 +4595,8 @@ package body Exp_Ch4 is
                  Make_Op_Ge (Loc,
                    Left_Opnd  => Lop,
                    Right_Opnd => Low_Bound (Rop)));
-               Analyze_And_Resolve (N, Rtyp);
-
-               return;
+               Analyze_And_Resolve (N, Restyp);
+               goto Leave;
             end if;
 
             --  We couldn't optimize away the range check, but there is one
@@ -4632,7 +4637,7 @@ package body Exp_Ch4 is
 
          --  For all other cases of an explicit range, nothing to be done
 
-         return;
+         goto Leave;
 
       --  Here right operand is a subtype mark
 
@@ -4660,7 +4665,7 @@ package body Exp_Ch4 is
                if Tagged_Type_Expansion then
                   Tagged_Membership (N, SCIL_Node, New_N);
                   Rewrite (N, New_N);
-                  Analyze_And_Resolve (N, Rtyp);
+                  Analyze_And_Resolve (N, Restyp);
 
                   --  Update decoration of relocated node referenced by the
                   --  SCIL node.
@@ -4670,7 +4675,7 @@ package body Exp_Ch4 is
                   end if;
                end if;
 
-               return;
+               goto Leave;
 
             --  If type is scalar type, rewrite as x in t'First .. t'Last.
             --  This reason we do this is that the bounds may have the wrong
@@ -4689,8 +4694,8 @@ package body Exp_Ch4 is
                      Make_Attribute_Reference (Loc,
                        Attribute_Name => Name_Last,
                        Prefix => New_Reference_To (Typ, Loc))));
-               Analyze_And_Resolve (N, Rtyp);
-               return;
+               Analyze_And_Resolve (N, Restyp);
+               goto Leave;
 
             --  Ada 2005 (AI-216): Program_Error is raised when evaluating
             --  a membership test if the subtype mark denotes a constrained
@@ -4709,7 +4714,7 @@ package body Exp_Ch4 is
                --  test as False.
 
                Rewrite (N, New_Occurrence_Of (Standard_False, Loc));
-               return;
+               goto Leave;
             end if;
 
             --  Here we have a non-scalar type
@@ -4720,7 +4725,7 @@ package body Exp_Ch4 is
 
             if not Is_Constrained (Typ) then
                Rewrite (N, New_Reference_To (Standard_True, Loc));
-               Analyze_And_Resolve (N, Rtyp);
+               Analyze_And_Resolve (N, Restyp);
 
             --  For the constrained array case, we have to check the subscripts
             --  for an exact match if the lengths are non-zero (the lengths
@@ -4788,7 +4793,7 @@ package body Exp_Ch4 is
                   end if;
 
                   Rewrite (N, Cond);
-                  Analyze_And_Resolve (N, Rtyp);
+                  Analyze_And_Resolve (N, Restyp);
                end Check_Subscripts;
 
             --  These are the cases where constraint checks may be required,
@@ -4819,10 +4824,34 @@ package body Exp_Ch4 is
                end if;
 
                Rewrite (N, Cond);
-               Analyze_And_Resolve (N, Rtyp);
+               Analyze_And_Resolve (N, Restyp);
             end if;
          end;
       end if;
+
+   --  At this point, we have done the processing required for the basic
+   --  membership test, but not yet dealt with the predicate.
+
+   <<Leave>>
+
+      --  If a predicate is present, then we do the predicate test
+
+      if Present (Predicate_Function (Rtyp)) then
+         Rewrite (N,
+           Make_And_Then (Loc,
+             Left_Opnd  => Relocate_Node (N),
+             Right_Opnd => Make_Predicate_Call (Rtyp, Lop)));
+
+         --  Analyze new expression, mark left operand as analyzed to
+         --  avoid infinite recursion adding predicate calls.
+
+         Set_Analyzed (Left_Opnd (N));
+         Analyze_And_Resolve (N, Standard_Boolean);
+
+         --  All done, skip attempt at compile time determination of result
+
+         return;
+      end if;
    end Expand_N_In;
 
    --------------------------------

gcc/ada/exp_util.adb

@@ -4086,6 +4086,51 @@ package body Exp_Util is
             Make_Integer_Literal (Loc, 0));
    end Make_Non_Empty_Check;
 
+   -------------------------
+   -- Make_Predicate_Call --
+   -------------------------
+
+   function Make_Predicate_Call
+     (Typ  : Entity_Id;
+      Expr : Node_Id) return Node_Id
+   is
+      Loc : constant Source_Ptr := Sloc (Expr);
+
+   begin
+      pragma Assert (Present (Predicate_Function (Typ)));
+
+      return
+        Make_Function_Call (Loc,
+          Name                   =>
+            New_Occurrence_Of (Predicate_Function (Typ), Loc),
+          Parameter_Associations => New_List (Relocate_Node (Expr)));
+   end Make_Predicate_Call;
+
+   --------------------------
+   -- Make_Predicate_Check --
+   --------------------------
+
+   function Make_Predicate_Check
+     (Typ  : Entity_Id;
+      Expr : Node_Id) return Node_Id
+   is
+      Loc : constant Source_Ptr := Sloc (Expr);
+
+   begin
+      return
+        Make_Pragma (Loc,
+          Pragma_Identifier            =>
+            Make_Identifier (Loc,
+              Name_Check),
+          Pragma_Argument_Associations => New_List (
+            Make_Pragma_Argument_Association (Loc,
+              Expression =>
+                Make_Identifier (Loc,
+                  Chars => Name_Predicate)),
+            Make_Pragma_Argument_Association (Loc,
+              Expression => Make_Predicate_Call (Typ, Expr))));
+   end Make_Predicate_Check;
+
    ----------------------------
    -- Make_Subtype_From_Expr --
    ----------------------------

gcc/ada/exp_util.ads

@@ -566,7 +566,21 @@ package Exp_Util is
    --  Expr is an object of a type which Has_Invariants set (and which thus
    --  also has an Invariant_Procedure set). If invariants are enabled, this
    --  function returns a call to the Invariant procedure passing Expr as the
-   --  argument.
+   --  argument, and returns it unanalyzed. If invariants are not enabled,
+   --  returns a null statement.
+
+   function Make_Predicate_Call
+     (Typ  : Entity_Id;
+      Expr : Node_Id) return Node_Id;
+   --  Typ is a type with Predicate_Function set. This routine builds a call to
+   --  this function passing Expr as the argument, and returns it unanalyzed.
+
+   function Make_Predicate_Check
+     (Typ  : Entity_Id;
+      Expr : Node_Id) return Node_Id;
+   --  Typ is a type with Predicate_Function set. This routine builds a Check
+   --  pragma whose first argument is Predicate, and the second argument is a
+   --  call to the this predicate function with Expr as the argument.
 
    function Make_Subtype_From_Expr
      (E       : Node_Id;

gcc/ada/freeze.adb

@@ -3787,6 +3787,28 @@ package body Freeze is
             end if;
          end if;
 
+         --  If we have predicates, then this is where we build the predicate
+         --  function, and return the spec and body as freeze actions.
+
+         if Has_Predicates (E) then
+            declare
+               FDecl : Node_Id;
+               FBody : Node_Id;
+
+            begin
+               Build_Predicate_Function (E, FDecl, FBody);
+
+               if Present (FDecl) then
+                  if No (Result) then
+                     Result := Empty_List;
+                  end if;
+
+                  Append_To (Result, FDecl);
+                  Append_To (Result, FBody);
+               end if;
+            end;
+         end if;
+
          --  Generic types are never seen by the back-end, and are also not
          --  processed by the expander (since the expander is turned off for
          --  generic processing), so we never need freeze nodes for them.

gcc/ada/sem_ch13.ads

@@ -57,11 +57,25 @@ package Sem_Ch13 is
       PDecl : out Node_Id;
       PBody : out Node_Id);
    --  If Typ has Invariants (indicated by Has_Invariants being set for Typ,
-   --  indicating the presence of Pragma Invariant entries on the rep chain,
+   --  indicating the presence of pragma Invariant entries on the rep chain,
    --  note that Invariant aspects are converted to pragma Invariant), then
    --  this procedure builds the spec and body for the corresponding Invariant
-   --  procedure, returning themn in PDecl and PBody. In some error situations
-   --  no procedure is built, in which case PDecl/PBody are empty on return.
+   --  procedure, returning themn in PDecl and PBody. Invariant_Procedure is
+   --  set for Typ. In some error situations no procedure is built, in which
+   --  case PDecl/PBody are empty on return.
+
+   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.
 
    procedure Check_Record_Representation_Clause (N : Node_Id);
    --  This procedure completes the analysis of a record representation clause

gcc/ada/sem_ch3.adb

@@ -484,8 +484,8 @@ package body Sem_Ch3 is
    --  operations of progenitors of Tagged_Type, and replace the subsidiary
    --  subtypes with Tagged_Type, to build the specs of the inherited interface
    --  primitives. The derived primitives are aliased to those of the
-   --  interface. This routine takes care also of transferring to the full-view
-   --  subprograms associated with the partial-view of Tagged_Type that cover
+   --  interface. This routine takes care also of transferring to the full view
+   --  subprograms associated with the partial view of Tagged_Type that cover
    --  interface primitives.
 
    procedure Derived_Standard_Character
@@ -1359,6 +1359,12 @@ package body Sem_Ch3 is
          pragma Assert (Is_Tagged_Type (Iface)
            and then Is_Interface (Iface));
 
+         --  This is a reasonable place to propagate predicates
+
+         if Has_Predicates (Iface) then
+            Set_Has_Predicates (Typ);
+         end if;
+
          Def :=
            Make_Component_Definition (Loc,
              Aliased_Present    => True,
@@ -2300,7 +2306,7 @@ package body Sem_Ch3 is
       end if;
 
       if Etype (T) = Any_Type then
-         goto Leave;
+         return;
       end if;
 
       --  Some common processing for all types
@@ -2395,8 +2401,9 @@ package body Sem_Ch3 is
       Set_Optimize_Alignment_Flags (Def_Id);
       Check_Eliminated (Def_Id);
 
-      <<Leave>>
+      if Nkind (N) = N_Full_Type_Declaration then
          Analyze_Aspect_Specifications (N, Def_Id, Aspect_Specifications (N));
+      end if;
    end Analyze_Full_Type_Declaration;
 
    ----------------------------------
@@ -3835,6 +3842,7 @@ 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));
 
       --  In the case where there is no constraint given in the subtype
       --  indication, Process_Subtype just returns the Subtype_Mark, so its
@@ -7668,6 +7676,12 @@ package body Sem_Ch3 is
          Set_Has_Invariants (Derived_Type);
       end if;
 
+      --  We similarly inherit predicates
+
+      if Has_Predicates (Parent_Type) then
+         Set_Has_Predicates (Derived_Type);
+      end if;
+
       --  The derived type inherits the representation clauses of the parent.
       --  However, for a private type that is completed by a derivation, there
       --  may be operation attributes that have been specified already (stream
@@ -17186,6 +17200,44 @@ package body Sem_Ch3 is
                --  Copy Invariant procedure to private declaration
 
                Set_Invariant_Procedure (Priv_T, Invariant_Procedure (Full_T));
+               Set_Has_Invariants (Priv_T);
+            end if;
+         end;
+      end if;
+
+      --  Propagate predicates to full type, and also build the predicate
+      --  procedure at this time, in the same way as we did for invariants.
+
+      if Has_Predicates (Priv_T) then
+         declare
+            FDecl : Entity_Id;
+            FBody : Entity_Id;
+            Packg : constant Node_Id := Declaration_Node (Scope (Priv_T));
+
+         begin
+            Build_Predicate_Function (Full_T, FDecl, FBody);
+
+            --  Error defense, normally this should be set
+
+            if Present (FDecl) then
+
+               --  Spec goes at the end of the public part of the package.
+               --  That's behind us, so we have to manually analyze the
+               --  inserted spec.
+
+               Append_To (Visible_Declarations (Packg), FDecl);
+               Analyze (FDecl);
+
+               --  Body goes at the end of the private part of the package.
+               --  That's ahead of us so it will get analyzed later on when
+               --  we come to it.
+
+               Append_To (Private_Declarations (Packg), FBody);
+
+               --  Copy Predicate procedure to private declaration
+
+               Set_Predicate_Function (Priv_T, Predicate_Function (Full_T));
+               Set_Has_Predicates (Priv_T);
             end if;
          end;
       end if;

gcc/ada/sem_eval.adb

@@ -2282,6 +2282,15 @@ package body Sem_Eval is
          return;
       end if;
 
+      --  Ignore if types involved have predicates
+
+      if Present (Predicate_Function (Etype (Left)))
+           or else
+         Present (Predicate_Function (Etype (Right)))
+      then
+         return;
+      end if;
+
       --  Case of right operand is a subtype name
 
       if Is_Entity_Name (Right) then

gcc/ada/sem_prag.adb

@@ -11172,8 +11172,7 @@ package body Sem_Prag is
 
          --  pragma Predicate
          --    ([Entity =>]    type_LOCAL_NAME,
-         --     [Check  =>]    EXPRESSION
-         --     [,[Message =>] String_Expression]);
+         --     [Check  =>]    EXPRESSION);
 
          when Pragma_Predicate => Predicate : declare
             Type_Id : Node_Id;
@@ -11184,16 +11183,10 @@ package body Sem_Prag is
 
          begin
             GNAT_Pragma;
-            Check_At_Least_N_Arguments (2);
-            Check_At_Most_N_Arguments (3);
+            Check_Arg_Count (2);
             Check_Optional_Identifier (Arg1, Name_Entity);
             Check_Optional_Identifier (Arg2, Name_Check);
 
-            if Arg_Count = 3 then
-               Check_Optional_Identifier (Arg3, Name_Message);
-               Check_Arg_Is_Static_Expression (Arg3, Standard_String);
-            end if;
-
             Check_Arg_Is_Local_Name (Arg1);
 
             Type_Id := Get_Pragma_Arg (Arg1);
@@ -11206,8 +11199,10 @@ package body Sem_Prag is
 
             --  The remaining processing is simply to link the pragma on to
             --  the rep item chain, for processing when the type is frozen.
-            --  This is accomplished by a call to Rep_Item_Too_Late.
+            --  This is accomplished by a call to Rep_Item_Too_Late. We also
+            --  mark the type as having predicates.
 
+            Set_Has_Predicates (Typ);
             Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
          end Predicate;