Patchwork [Ada] Prepare for implementation of Predicate aspect

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

Comments

Arnaud Charlet - Oct. 21, 2010, 10:30 a.m.
This patch is the first step in implementing the new Ada 2012
Predicate aspect. No test required, since it is not doing much
yet, just recognizing and storing the aspect.

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

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.

Patch

Index: exp_util.adb
===================================================================
--- exp_util.adb	(revision 165760)
+++ exp_util.adb	(working copy)
@@ -3998,6 +3998,9 @@  package body Exp_Util is
       Typ : constant Entity_Id  := Etype (Expr);
 
    begin
+      pragma Assert
+        (Has_Invariants (Typ) and then Present (Invariant_Procedure (Typ)));
+
       if Check_Enabled (Name_Invariant)
            or else
          Check_Enabled (Name_Assertion)
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 165760)
+++ einfo.adb	(working copy)
@@ -230,7 +230,7 @@  package body Einfo is
    --    Extra_Formals                   Node28
    --    Underlying_Record_View          Node28
 
-   --    Invariant_Procedure             Node29
+   --    Subprograms_For_Type            Node29
 
    ---------------------------------------------
    -- Usage of Flags in Defining Entity Nodes --
@@ -513,8 +513,8 @@  package body Einfo is
    --    OK_To_Rename                    Flag247
    --    Has_Inheritable_Invariants      Flag248
    --    OK_To_Reference                 Flag249
+   --    Has_Predicates                  Flag250
 
-   --    (unused)                        Flag250
    --    (unused)                        Flag251
    --    (unused)                        Flag252
    --    (unused)                        Flag253
@@ -1287,7 +1287,7 @@  package body Einfo is
 
    function Has_Invariants (Id : E) return B is
    begin
-      pragma Assert (Is_Type (Id));
+      pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure);
       return Flag232 (Id);
    end Has_Invariants;
 
@@ -1409,6 +1409,12 @@  package body Einfo is
       return Flag212 (Id);
    end Has_Pragma_Unreferenced_Objects;
 
+   function Has_Predicates (Id : E) return B is
+   begin
+      pragma Assert (Is_Type (Id) or else Ekind (Id) = E_Procedure);
+      return Flag250 (Id);
+   end Has_Predicates;
+
    function Has_Primitive_Operations (Id : E) return B is
    begin
       pragma Assert (Is_Type (Id));
@@ -1566,12 +1572,6 @@  package body Einfo is
       return Elist25 (Id);
    end Interfaces;
 
-   function Invariant_Procedure (Id : E) return N is
-   begin
-      pragma Assert (Is_Type (Id));
-      return Node29 (Id);
-   end Invariant_Procedure;
-
    function In_Package_Body (Id : E) return B is
    begin
       return Flag48 (Id);
@@ -2651,6 +2651,12 @@  package body Einfo is
       return Node15 (Id);
    end String_Literal_Low_Bound;
 
+   function Subprograms_For_Type (Id : E) return E is
+   begin
+      pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
+      return Node29 (Id);
+   end Subprograms_For_Type;
+
    function Suppress_Elaboration_Warnings (Id : E) return B is
    begin
       return Flag148 (Id);
@@ -3722,7 +3728,9 @@  package body Einfo is
 
    procedure Set_Has_Invariants (Id : E; V : B := True) is
    begin
-      pragma Assert (Is_Type (Id));
+      pragma Assert (Is_Type (Id)
+        or else Ekind (Id) = E_Procedure
+        or else Ekind (Id) = E_Void);
       Set_Flag232 (Id, V);
    end Set_Has_Invariants;
 
@@ -3853,6 +3861,14 @@  package body Einfo is
       Set_Flag212 (Id, V);
    end Set_Has_Pragma_Unreferenced_Objects;
 
+   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_Void);
+      Set_Flag250 (Id, V);
+   end Set_Has_Predicates;
+
    procedure Set_Has_Primitive_Operations (Id : E; V : B := True) is
    begin
       pragma Assert (Id = Base_Type (Id));
@@ -4012,12 +4028,6 @@  package body Einfo is
       Set_Elist25 (Id, V);
    end Set_Interfaces;
 
-   procedure Set_Invariant_Procedure (Id : E; V : N) is
-   begin
-      pragma Assert (Is_Type (Id));
-      Set_Node29 (Id, V);
-   end Set_Invariant_Procedure;
-
    procedure Set_In_Package_Body (Id : E; V : B := True) is
    begin
       Set_Flag48 (Id, V);
@@ -5146,6 +5156,12 @@  package body Einfo is
       Set_Node15 (Id, V);
    end Set_String_Literal_Low_Bound;
 
+   procedure Set_Subprograms_For_Type (Id : E; V : E) is
+   begin
+      pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
+      Set_Node29 (Id, V);
+   end Set_Subprograms_For_Type;
+
    procedure Set_Suppress_Elaboration_Warnings (Id : E; V : B := True) is
    begin
       Set_Flag148 (Id, V);
@@ -6129,6 +6145,33 @@  package body Einfo is
       end if;
    end Implementation_Base_Type;
 
+   -------------------------
+   -- Invariant_Procedure --
+   -------------------------
+
+   function Invariant_Procedure (Id : E) return E is
+      S : Entity_Id;
+
+   begin
+      pragma Assert (Is_Type (Id) and then Has_Invariants (Id));
+
+      if No (Subprograms_For_Type (Id)) then
+         return Empty;
+
+      else
+         S := Subprograms_For_Type (Id);
+         while Present (S) loop
+            if Has_Invariants (S) then
+               return S;
+            else
+               S := Subprograms_For_Type (S);
+            end if;
+         end loop;
+
+         return Empty;
+      end if;
+   end Invariant_Procedure;
+
    ---------------------
    -- Is_Boolean_Type --
    ---------------------
@@ -6222,6 +6265,33 @@  package body Einfo is
         Ekind (Id) = E_Generic_Package;
    end Is_Package_Or_Generic_Package;
 
+   -------------------------
+   -- Predicate_Procedure --
+   -------------------------
+
+   function Predicate_Procedure (Id : E) return E is
+      S : Entity_Id;
+
+   begin
+      pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
+
+      if No (Subprograms_For_Type (Id)) then
+         return Empty;
+
+      else
+         S := Subprograms_For_Type (Id);
+         while Present (S) loop
+            if Has_Predicates (S) then
+               return S;
+            else
+               S := Subprograms_For_Type (S);
+            end if;
+         end loop;
+
+         return Empty;
+      end if;
+   end Predicate_Procedure;
+
    ---------------
    -- Is_Prival --
    ---------------
@@ -6766,6 +6836,54 @@  package body Einfo is
       end case;
    end Set_Component_Alignment;
 
+   -----------------------------
+   -- Set_Invariant_Procedure --
+   -----------------------------
+
+   procedure Set_Invariant_Procedure (Id : E; V : E) is
+      S : Entity_Id;
+
+   begin
+      pragma Assert (Is_Type (Id) and then Has_Invariants (Id));
+
+      S := Subprograms_For_Type (Id);
+      Set_Subprograms_For_Type (Id, V);
+
+      while Present (S) loop
+         if Has_Invariants (S) then
+            raise Program_Error;
+         else
+            S := Subprograms_For_Type (S);
+         end if;
+      end loop;
+
+      Set_Subprograms_For_Type (Id, V);
+   end Set_Invariant_Procedure;
+
+   -----------------------------
+   -- Set_Predicate_Procedure --
+   -----------------------------
+
+   procedure Set_Predicate_Procedure (Id : E; V : E) is
+      S : Entity_Id;
+
+   begin
+      pragma Assert (Is_Type (Id) and then Has_Predicates (Id));
+
+      S := Subprograms_For_Type (Id);
+      Set_Subprograms_For_Type (Id, V);
+
+      while Present (S) loop
+         if Has_Predicates (S) then
+            raise Program_Error;
+         else
+            S := Subprograms_For_Type (S);
+         end if;
+      end loop;
+
+      Set_Subprograms_For_Type (Id, V);
+   end Set_Predicate_Procedure;
+
    -----------------
    -- Size_Clause --
    -----------------
@@ -7063,6 +7181,7 @@  package body Einfo is
       W ("Has_Pragma_Unmodified",           Flag233 (Id));
       W ("Has_Pragma_Unreferenced",         Flag180 (Id));
       W ("Has_Pragma_Unreferenced_Objects", Flag212 (Id));
+      W ("Has_Predicates",                  Flag250 (Id));
       W ("Has_Primitive_Operations",        Flag120 (Id));
       W ("Has_Private_Declaration",         Flag155 (Id));
       W ("Has_Qualified_Name",              Flag161 (Id));
@@ -8246,9 +8365,6 @@  package body Einfo is
    procedure Write_Field28_Name (Id : Entity_Id) is
    begin
       case Ekind (Id) is
-         when Private_Kind =>
-            Write_Str ("Invariant_Procedure");
-
          when E_Procedure | E_Function | E_Entry           =>
             Write_Str ("Extra_Formals");
 
@@ -8264,7 +8380,7 @@  package body Einfo is
    begin
       case Ekind (Id) is
          when Type_Kind =>
-            Write_Str ("Invariant_Procedure");
+            Write_Str ("Subprograms_For_Type");
 
          when others                                       =>
             Write_Str ("Field29??");
Index: einfo.ads
===================================================================
--- einfo.ads	(revision 165762)
+++ einfo.ads	(working copy)
@@ -1507,14 +1507,16 @@  package Einfo is
 --       Interrupt_Handler applies.
 
 --    Has_Invariants (Flag232)
---       Present in all type entities. Set True in private types if an
---       Invariant or Invariant'Class aspect applies to the type, or if the
---       type inherits one or more Invariant'Class aspects. Also set in the
---       corresponding full type. Note: if this flag is set True, then usually
---       the Invariant_Procedure field is set once the type is frozen, however
---       this may not be true in some error situations. Note that it might be
---       the full type which has inheritable invariants, and then the flag will
---       also be set in the private type.
+--       Present in all type entities and in subprogram entities. Set True in
+--       private types if an Invariant or Invariant'Class aspect applies to the
+--       type, or if the type inherits one or more Invariant'Class aspects.
+--       Also set in the corresponding full type. Note: if this flag is set
+--       True, then usually the Invariant_Procedure attribute is set once the
+--       type is frozen, however this may not be true in some error situations.
+--       Note that it might be the full type which has inheritable invariants,
+--       and then the flag will also be set in the private type. Also set in
+--       the invariant procedure entity, to distinguish it among entries in the
+--       Subprograms_For_Type.
 
 --    Has_Inheritable_Invariants (Flag248)
 --       Present in all type entities. Set True in private types from which one
@@ -1671,6 +1673,13 @@  package Einfo is
 --       (but unlike the case with pragma Unreferenced, it is ok to reference
 --       such an object and no warning is generated.
 
+--    Has_Predicates (Flag250)
+--       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
+--       entries in the Subprograms_For_Type.
+
 --    Has_Primitive_Operations (Flag120) [base type only]
 --       Present in all type entities. Set if at least one primitive operation
 --       is defined for the type.
@@ -1900,15 +1909,18 @@  package Einfo is
 --       External_Name of the imported Java field (which is generally needed,
 --       because Java names are case sensitive).
 
---    Invariant_Procedure (Node29)
+--    Invariant_Procedure (synthesized)
 --       Present in types and subtypes. Set for private types if one or more
 --       Invariant, or Invariant'Class, or inherited Invariant'Class aspects
 --       apply to the type. Points to the entity for a procedure which checks
 --       the invariant. This invariant procedure takes a single argument of the
 --       given type, and returns if the invariant holds, or raises exception
 --       Assertion_Error with an appropriate message if it does not hold. This
---       field is present but always empty for private subtypes. This field is
---       also set for the corresponding full type.
+--       attribute is present but always empty for private subtypes. This
+--       attribute is also set for the corresponding full type.
+--
+--       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.
 
 --    In_Use (Flag8)
 --       Present in packages and types. Set when analyzing a use clause for
@@ -3264,6 +3276,17 @@  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)
+--       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.
+--
+--       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.
+
 --    Prival (Node17)
 --       Present in private components of protected types. Refers to the entity
 --       of the component renaming declaration generated inside protected
@@ -3632,6 +3655,16 @@  package Einfo is
 --       the low bound of the applicable index constraint if there is one,
 --       or a copy of the low bound of the index base type if not.
 
+--    Subprograms_For_Type (Node29)
+--       Present in all type entities, and in subprogram entities. This is used
+--       to hold a list of subprogram entities for subprograms associated with
+--       the type, linked through the Suprogram_List field of the subprogram
+--       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
+--       names to access entries in this list.
+
 --    Suppress_Elaboration_Warnings (Flag148)
 --       Present in all entities, can be set only for subprogram entities and
 --       for variables. If this flag is set then Sem_Elab will not generate
@@ -4733,7 +4766,7 @@  package Einfo is
    --    Alignment                           (Uint14)
    --    Related_Expression                  (Node24)
    --    Current_Use_Clause                  (Node27)
-   --    Invariant_Procedure                 (Node29)
+   --    Subprograms_For_Type                (Node29)
 
    --    Depends_On_Private                  (Flag14)
    --    Discard_Names                       (Flag88)
@@ -4752,6 +4785,7 @@  package Einfo is
    --    Has_Object_Size_Clause              (Flag172)
    --    Has_Pragma_Preelab_Init             (Flag221)
    --    Has_Pragma_Unreferenced_Objects     (Flag212)
+   --    Has_Predicates                      (Flag250)
    --    Has_Primitive_Operations            (Flag120)  (base type only)
    --    Has_Size_Clause                     (Flag29)
    --    Has_Specified_Layout                (Flag100)  (base type only)
@@ -4796,7 +4830,9 @@  package Einfo is
    --    Base_Type                           (synth)
    --    Has_Private_Ancestor                (synth)
    --    Implementation_Base_Type            (synth)
+   --    Invariant_Procedure                 (synth)
    --    Is_Access_Protected_Subprogram_Type (synth)
+   --    Predicate_Procedure                 (synth)
    --    Root_Type                           (synth)
    --    Size_Clause                         (synth)
 
@@ -5095,6 +5131,7 @@  package Einfo is
    --    Overridden_Operation                (Node26)
    --    Wrapped_Entity                      (Node27)   (non-generic case only)
    --    Extra_Formals                       (Node28)
+   --    Subprograms_For_Type                (Node29)
    --    Body_Needed_For_SAL                 (Flag40)
    --    Elaboration_Entity_Required         (Flag174)
    --    Default_Expressions_Processed       (Flag108)
@@ -5103,10 +5140,12 @@  package Einfo is
    --    Discard_Names                       (Flag88)
    --    Has_Completion                      (Flag26)
    --    Has_Controlling_Result              (Flag98)
+   --    Has_Invariants                      (Flag232)
    --    Has_Master_Entity                   (Flag21)
    --    Has_Missing_Return                  (Flag142)
    --    Has_Nested_Block_With_Handler       (Flag101)
    --    Has_Postconditions                  (Flag240)
+   --    Has_Predicates                      (Flag250)
    --    Has_Recursive_Call                  (Flag143)
    --    Has_Subprogram_Descriptor           (Flag93)
    --    Is_Abstract_Subprogram              (Flag19)   (non-generic case only)
@@ -5236,7 +5275,10 @@  package Einfo is
    --    First_Entity                        (Node17)
    --    Alias                               (Node18)
    --    Last_Entity                         (Node20)
+   --    Subprograms_For_Type                (Node29)
+   --    Has_Invariants                      (Flag232)
    --    Has_Postconditions                  (Flag240)
+   --    Has_Predicates                      (Flag250)
    --    Is_Machine_Code_Subprogram          (Flag137)
    --    Is_Pure                             (Flag44)
    --    Is_Intrinsic_Subprogram             (Flag64)
@@ -5364,9 +5406,11 @@  package Einfo is
    --    Delay_Subprogram_Descriptors        (Flag50)
    --    Discard_Names                       (Flag88)
    --    Has_Completion                      (Flag26)
+   --    Has_Invariants                      (Flag232)
    --    Has_Master_Entity                   (Flag21)
    --    Has_Nested_Block_With_Handler       (Flag101)
    --    Has_Postconditions                  (Flag240)
+   --    Has_Predicates                      (Flag250)
    --    Has_Subprogram_Descriptor           (Flag93)
    --    Is_Abstract_Subprogram              (Flag19)   (non-generic case only)
    --    Is_Asynchronous                     (Flag81)
@@ -5965,6 +6009,7 @@  package Einfo is
    function Has_Pragma_Unmodified               (Id : E) return B;
    function Has_Pragma_Unreferenced             (Id : E) return B;
    function Has_Pragma_Unreferenced_Objects     (Id : E) return B;
+   function Has_Predicates                      (Id : E) return B;
    function Has_Primitive_Operations            (Id : E) return B;
    function Has_Qualified_Name                  (Id : E) return B;
    function Has_RACW                            (Id : E) return B;
@@ -5996,7 +6041,6 @@  package Einfo is
    function Interface_Alias                     (Id : E) return E;
    function Interfaces                          (Id : E) return L;
    function Interface_Name                      (Id : E) return N;
-   function Invariant_Procedure                 (Id : E) return N;
    function Is_AST_Entry                        (Id : E) return B;
    function Is_Abstract_Subprogram              (Id : E) return B;
    function Is_Abstract_Type                    (Id : E) return B;
@@ -6179,6 +6223,7 @@  package Einfo is
    function Strict_Alignment                    (Id : E) return B;
    function String_Literal_Length               (Id : E) return U;
    function String_Literal_Low_Bound            (Id : E) return N;
+   function Subprograms_For_Type                (Id : E) return E;
    function Suppress_Elaboration_Warnings       (Id : E) return B;
    function Suppress_Init_Proc                  (Id : E) return B;
    function Suppress_Style_Checks               (Id : E) return B;
@@ -6531,6 +6576,7 @@  package Einfo is
    procedure Set_Has_Pragma_Unmodified           (Id : E; V : B := True);
    procedure Set_Has_Pragma_Unreferenced         (Id : E; V : B := True);
    procedure Set_Has_Pragma_Unreferenced_Objects (Id : E; V : B := True);
+   procedure Set_Has_Predicates                  (Id : E; V : B := True);
    procedure Set_Has_Primitive_Operations        (Id : E; V : B := True);
    procedure Set_Has_Private_Declaration         (Id : E; V : B := True);
    procedure Set_Has_Qualified_Name              (Id : E; V : B := True);
@@ -6563,7 +6609,6 @@  package Einfo is
    procedure Set_Inner_Instances                 (Id : E; V : L);
    procedure Set_Interface_Alias                 (Id : E; V : E);
    procedure Set_Interface_Name                  (Id : E; V : N);
-   procedure Set_Invariant_Procedure             (Id : E; V : N);
    procedure Set_Is_AST_Entry                    (Id : E; V : B := True);
    procedure Set_Is_Abstract_Subprogram          (Id : E; V : B := True);
    procedure Set_Is_Abstract_Type                (Id : E; V : B := True);
@@ -6753,6 +6798,7 @@  package Einfo is
    procedure Set_Strict_Alignment                (Id : E; V : B := True);
    procedure Set_String_Literal_Length           (Id : E; V : U);
    procedure Set_String_Literal_Low_Bound        (Id : E; V : N);
+   procedure Set_Subprograms_For_Type            (Id : E; V : E);
    procedure Set_Suppress_Elaboration_Warnings   (Id : E; V : B := True);
    procedure Set_Suppress_Init_Proc              (Id : E; V : B := True);
    procedure Set_Suppress_Style_Checks           (Id : E; V : B := True);
@@ -6773,6 +6819,16 @@  package Einfo is
    procedure Set_Was_Hidden                      (Id : E; V : B := True);
    procedure Set_Wrapped_Entity                  (Id : E; V : E);
 
+   ---------------------------------------------------
+   -- Access to Subprograms in Subprograms_For_Type --
+   ---------------------------------------------------
+
+   function Invariant_Procedure                 (Id : E) return N;
+   function Predicate_Procedure                 (Id : E) return N;
+
+   procedure Set_Invariant_Procedure            (Id : E; V : E);
+   procedure Set_Predicate_Procedure            (Id : E; V : E);
+
    -----------------------------------
    -- Field Initialization Routines --
    -----------------------------------
@@ -7210,6 +7266,7 @@  package Einfo is
    pragma Inline (Has_Pragma_Unmodified);
    pragma Inline (Has_Pragma_Unreferenced);
    pragma Inline (Has_Pragma_Unreferenced_Objects);
+   pragma Inline (Has_Predicates);
    pragma Inline (Has_Primitive_Operations);
    pragma Inline (Has_Private_Declaration);
    pragma Inline (Has_Qualified_Name);
@@ -7243,7 +7300,6 @@  package Einfo is
    pragma Inline (Inner_Instances);
    pragma Inline (Interface_Alias);
    pragma Inline (Interface_Name);
-   pragma Inline (Invariant_Procedure);
    pragma Inline (Is_AST_Entry);
    pragma Inline (Is_Abstract_Subprogram);
    pragma Inline (Is_Abstract_Type);
@@ -7475,6 +7531,7 @@  package Einfo is
    pragma Inline (Strict_Alignment);
    pragma Inline (String_Literal_Length);
    pragma Inline (String_Literal_Low_Bound);
+   pragma Inline (Subprograms_For_Type);
    pragma Inline (Suppress_Elaboration_Warnings);
    pragma Inline (Suppress_Init_Proc);
    pragma Inline (Suppress_Style_Checks);
@@ -7647,6 +7704,7 @@  package Einfo is
    pragma Inline (Set_Has_Pragma_Unmodified);
    pragma Inline (Set_Has_Pragma_Unreferenced);
    pragma Inline (Set_Has_Pragma_Unreferenced_Objects);
+   pragma Inline (Set_Has_Predicates);
    pragma Inline (Set_Has_Primitive_Operations);
    pragma Inline (Set_Has_Private_Declaration);
    pragma Inline (Set_Has_Qualified_Name);
@@ -7680,7 +7738,6 @@  package Einfo is
    pragma Inline (Set_Inner_Instances);
    pragma Inline (Set_Interface_Alias);
    pragma Inline (Set_Interface_Name);
-   pragma Inline (Set_Invariant_Procedure);
    pragma Inline (Set_Is_AST_Entry);
    pragma Inline (Set_Is_Abstract_Subprogram);
    pragma Inline (Set_Is_Abstract_Type);
@@ -7868,6 +7925,7 @@  package Einfo is
    pragma Inline (Set_Strict_Alignment);
    pragma Inline (Set_String_Literal_Length);
    pragma Inline (Set_String_Literal_Low_Bound);
+   pragma Inline (Set_Subprograms_For_Type);
    pragma Inline (Set_Suppress_Elaboration_Warnings);
    pragma Inline (Set_Suppress_Init_Proc);
    pragma Inline (Set_Suppress_Style_Checks);
Index: sem_prag.adb
===================================================================
--- sem_prag.adb	(revision 165761)
+++ sem_prag.adb	(working copy)
@@ -11166,6 +11166,51 @@  package body Sem_Prag is
             end if;
          end Precondition;
 
+         ---------------
+         -- Predicate --
+         ---------------
+
+         --  pragma Predicate
+         --    ([Entity =>]    type_LOCAL_NAME,
+         --     [Check  =>]    EXPRESSION
+         --     [,[Message =>] String_Expression]);
+
+         when Pragma_Predicate => Predicate : declare
+            Type_Id : Node_Id;
+            Typ     : Entity_Id;
+
+            Discard : Boolean;
+            pragma Unreferenced (Discard);
+
+         begin
+            GNAT_Pragma;
+            Check_At_Least_N_Arguments (2);
+            Check_At_Most_N_Arguments (3);
+            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);
+            Find_Type (Type_Id);
+            Typ := Entity (Type_Id);
+
+            if Typ = Any_Type then
+               return;
+            end if;
+
+            --  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.
+
+            Discard := Rep_Item_Too_Late (Typ, N, FOnly => True);
+         end Predicate;
+
          ------------------
          -- Preelaborate --
          ------------------
@@ -13919,6 +13964,7 @@  package body Sem_Prag is
       Pragma_Persistent_BSS                =>  0,
       Pragma_Postcondition                 => -1,
       Pragma_Precondition                  => -1,
+      Pragma_Predicate                     => -1,
       Pragma_Preelaborate                  => -1,
       Pragma_Preelaborate_05               => -1,
       Pragma_Priority                      => -1,
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 165760)
+++ exp_ch4.adb	(working copy)
@@ -8278,7 +8278,8 @@  package body Exp_Ch4 is
       --  Note: the Comes_From_Source check, and then the resetting of this
       --  flag prevents what would otherwise be an infinite recursion.
 
-      if Present (Invariant_Procedure (Target_Type))
+      if Has_Invariants (Target_Type)
+        and then Present (Invariant_Procedure (Target_Type))
         and then Comes_From_Source (N)
       then
          Set_Comes_From_Source (N, False);
Index: sem_ch6.adb
===================================================================
--- sem_ch6.adb	(revision 165761)
+++ sem_ch6.adb	(working copy)
@@ -9099,7 +9099,9 @@  package body Sem_Ch6 is
 
                --  Add invariant call if returning type with invariants
 
-               if Present (Invariant_Procedure (Etype (Rent))) then
+               if Has_Invariants (Etype (Rent))
+                 and then Present (Invariant_Procedure (Etype (Rent)))
+               then
                   Append_To (Plist,
                     Make_Invariant_Call (New_Occurrence_Of (Rent, Loc)));
                end if;
@@ -9121,6 +9123,7 @@  package body Sem_Ch6 is
             Formal := First_Formal (Designator);
             while Present (Formal) loop
                if Ekind (Formal) /= E_In_Parameter
+                 and then Has_Invariants (Etype (Formal))
                  and then Present (Invariant_Procedure (Etype (Formal)))
                then
                   Append_To (Plist,
Index: par-prag.adb
===================================================================
--- par-prag.adb	(revision 165755)
+++ par-prag.adb	(working copy)
@@ -1205,6 +1205,7 @@  begin
            Pragma_Persistent_BSS                |
            Pragma_Postcondition                 |
            Pragma_Precondition                  |
+           Pragma_Predicate                     |
            Pragma_Preelaborate                  |
            Pragma_Preelaborate_05               |
            Pragma_Priority                      |
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 165758)
+++ sem_ch13.adb	(working copy)
@@ -635,7 +635,7 @@  package body Sem_Ch13 is
       Ent    : Node_Id;
 
       Ins_Node : Node_Id := N;
-      --  Insert pragmas (other than Pre/Post) after this node
+      --  Insert pragmas (except Pre/Post/Invariant/Predicate) after this node
 
       --  The general processing involves building an attribute definition
       --  clause or a pragma node that corresponds to the access type. Then
@@ -1008,13 +1008,14 @@  package body Sem_Ch13 is
                   goto Continue;
                end;
 
-               --  Invariant aspect generates an Invariant 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 processing for the
-               --  pragma takes care of the required delay.
+               --  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.
 
-               when Aspect_Invariant =>
+               when Aspect_Invariant |
+                    Aspect_Predicate =>
 
                   --  Construct the pragma
 
@@ -1024,7 +1025,7 @@  package body Sem_Ch13 is
                         New_List (Ent, Relocate_Node (Expr)),
                       Class_Present                => Class_Present (Aspect),
                       Pragma_Identifier            =>
-                        Make_Identifier (Sloc (Id), Name_Invariant));
+                        Make_Identifier (Sloc (Id), Chars (Id)));
 
                   --  Add message unless exception messages are suppressed
 
@@ -1040,18 +1041,13 @@  package body Sem_Ch13 is
 
                   Set_From_Aspect_Specification (Aitem, True);
 
-                  --  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.
+                  --  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.
 
                   Insert_After (N, Aitem);
                   goto Continue;
-
-               --  Aspects currently unimplemented
-
-               when Aspect_Predicate =>
-                  Error_Msg_N ("aspect& not implemented", Identifier (Aspect));
-                  goto Continue;
             end case;
 
             Set_From_Aspect_Specification (Aitem, True);
@@ -3685,9 +3681,11 @@  package body Sem_Ch13 is
 
          --  Build procedure declaration
 
+         pragma Assert (Has_Invariants (Typ));
          SId :=
            Make_Defining_Identifier (Loc,
              Chars => New_External_Name (Chars (Typ), "Invariant"));
+         Set_Has_Invariants (SId);
          Set_Invariant_Procedure (Typ, SId);
 
          Spec :=
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl	(revision 165756)
+++ snames.ads-tmpl	(working copy)
@@ -139,7 +139,6 @@  package Snames is
 
    Name_Post                           : constant Name_Id := N + $;
    Name_Pre                            : constant Name_Id := N + $;
-   Name_Predicate                      : constant Name_Id := N + $;
 
    --  Some special names used by the expander. Note that the lower case u's
    --  at the start of these names get translated to extra underscores. These
@@ -507,6 +506,7 @@  package Snames is
    Name_Passive                        : constant Name_Id := N + $; -- GNAT
    Name_Postcondition                  : constant Name_Id := N + $; -- GNAT
    Name_Precondition                   : constant Name_Id := N + $; -- GNAT
+   Name_Predicate                      : constant Name_Id := N + $; -- GNAT
    Name_Preelaborable_Initialization   : constant Name_Id := N + $; -- Ada 05
    Name_Preelaborate                   : constant Name_Id := N + $;
    Name_Preelaborate_05                : constant Name_Id := N + $; -- GNAT
@@ -1596,6 +1596,7 @@  package Snames is
       Pragma_Passive,
       Pragma_Postcondition,
       Pragma_Precondition,
+      Pragma_Predicate,
       Pragma_Preelaborable_Initialization,
       Pragma_Preelaborate,
       Pragma_Preelaborate_05,
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb	(revision 165760)
+++ exp_ch3.adb	(working copy)
@@ -4576,7 +4576,7 @@  package body Exp_Ch3 is
          --  to clobber the object with an invalid value since if the exception
          --  is raised, then the object will go out of scope.
 
-         if Is_Private_Type (Typ)
+         if Has_Invariants (Typ)
            and then Present (Invariant_Procedure (Typ))
          then
             Insert_After (N,