Patchwork [Ada] Next stage in implementing predicate aspect

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 21, 2010, 10:33 a.m.
Message ID <20101021103350.GA31739@adacore.com>
Download mbox | patch
Permalink /patch/68568/
State New
Headers show

Comments

Arnaud Charlet - Oct. 21, 2010, 10:33 a.m.
This patch is the next stage in the implementation of
predicates, not ready for prime time yet.

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

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.

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165760)
+++ sem_ch3.adb	(working copy)
@@ -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;
Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 165763)
+++ exp_util.adb	(working copy)
@@ -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 --
    ----------------------------
Index: exp_util.ads
===================================================================
--- exp_util.ads	(revision 165755)
+++ exp_util.ads	(working copy)
@@ -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;
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 165763)
+++ einfo.adb	(working copy)
@@ -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 --
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 165763)
+++ einfo.ads	(working copy)
@@ -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 --
Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 165763)
+++ sem_prag.adb	(working copy)
@@ -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;
 
Index: freeze.adb
===================================================================
--- freeze.adb	(revision 165755)
+++ freeze.adb	(working copy)
@@ -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.
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 165763)
+++ exp_ch4.adb	(working copy)
@@ -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;
 
    --------------------------------
Index: sem_eval.adb
===================================================================
--- sem_eval.adb	(revision 165755)
+++ sem_eval.adb	(working copy)
@@ -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
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 165763)
+++ sem_ch13.adb	(working copy)
@@ -1008,14 +1008,14 @@  package body Sem_Ch13 is
                   goto Continue;
                end;
 
-               --  Invariant and Predicate aspects generate a corresponding
-               --  pragma with a first argument that is the entity, and the
-               --  second argument is the expression. This is inserted right
-               --  after the declaration, to get the required pragma placement.
-               --  The pragma processing takes care of the required delay.
+               --  Invariant aspects generate a corresponding pragma with a
+               --  first argument that is the entity, and the second argument
+               --  is the expression and anthird argument with an appropriate
+               --  message. This is inserted right after the declaration, to
+               --  get the required pragma placement. The pragma processing
+               --  takes care of the required delay.
 
-               when Aspect_Invariant |
-                    Aspect_Predicate =>
+               when Aspect_Invariant =>
 
                   --  Construct the pragma
 
@@ -1025,14 +1025,14 @@  package body Sem_Ch13 is
                         New_List (Ent, Relocate_Node (Expr)),
                       Class_Present                => Class_Present (Aspect),
                       Pragma_Identifier            =>
-                        Make_Identifier (Sloc (Id), Chars (Id)));
+                        Make_Identifier (Sloc (Id), Name_Invariant));
 
                   --  Add message unless exception messages are suppressed
 
                   if not Opt.Exception_Locations_Suppressed then
                      Append_To (Pragma_Argument_Associations (Aitem),
                        Make_Pragma_Argument_Association (Eloc,
-                         Chars     => Name_Message,
+                         Chars      => Name_Message,
                          Expression =>
                            Make_String_Literal (Eloc,
                              Strval => "failed invariant from "
@@ -1041,10 +1041,36 @@  package body Sem_Ch13 is
 
                   Set_From_Aspect_Specification (Aitem, True);
 
-                  --  For Invariant and Predicate cases, insert immediately
-                  --  after the entity declaration. We do not have to worry
-                  --  about delay issues since the pragma processing takes
-                  --  care of this.
+                  --  For Invariant case, insert immediately after the entity
+                  --  declaration. We do not have to worry about delay issues
+                  --  since the pragma processing takes care of this.
+
+                  Insert_After (N, Aitem);
+                  goto Continue;
+
+               --  Predicate aspects generate a corresponding pragma with a
+               --  first argument that is the entity, and the second argument
+               --  is the expression. This is inserted immediately after the
+               --  declaration, to get the required pragma placement. The
+               --  pragma processing takes care of the required delay.
+
+               when Aspect_Predicate =>
+
+                  --  Construct the pragma
+
+                  Aitem :=
+                    Make_Pragma (Loc,
+                      Pragma_Argument_Associations =>
+                        New_List (Ent, Relocate_Node (Expr)),
+                      Class_Present                => Class_Present (Aspect),
+                      Pragma_Identifier            =>
+                        Make_Identifier (Sloc (Id), Name_Predicate));
+
+                  Set_From_Aspect_Specification (Aitem, True);
+
+                  --  For Predicate case, insert immediately after the entity
+                  --  declaration. We do not have to worry about delay issues
+                  --  since the pragma processing takes care of this.
 
                   Insert_After (N, Aitem);
                   goto Continue;
@@ -3730,6 +3756,291 @@  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 statement 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
+            Exp :=
+              Make_Predicate_Call
+                (T,
+                 Convert_To (T,
+                   Make_Identifier (Loc,
+                     Chars => Object_Name)));
+
+            if No (Expr) then
+               Expr := Exp;
+            else
+               Expr :=
+                 Make_And_Then (Loc,
+                   Left_Opnd  => Relocate_Node (Expr),
+                   Right_Opnd => Exp);
+            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 instance of the type entity, keep going
+
+            else
+               return OK;
+            end if;
+         end Replace_Node;
+
+      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);
+
+               --  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 reognized as legitimate.
+
+               Set_OK_To_Reference (Typ, True);
+               Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
+               Set_OK_To_Reference (Typ, False);
+               Replace_Type (Arg2);
+
+               --  See if this predicate pragma is for the current type
+
+               if Entity (Arg1) = Typ then
+
+                  --  We have a match, 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;
+
+      --  Deal with ancestor subtype and parent type
+
+      declare
+         Atyp : constant Entity_Id := Ancestor_Subtype (Typ);
+
+      begin
+         --  If ancestor subtype present, add its predicates
+
+         if Present (Atyp) then
+            Add_Call (Atyp);
+
+         --  Else if this is derived, add predicates of parent type
+
+         elsif Is_Derived_Type (Typ) then
+            Add_Call (Etype (Base_Type (Typ)));
+         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;
+
    -----------------------------------
    -- Check_Constant_Address_Clause --
    -----------------------------------
Index: sem_ch13.ads
===================================================================
--- sem_ch13.ads	(revision 165755)
+++ sem_ch13.ads	(working copy)
@@ -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