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: r165763

gcc/ada/ChangeLog

+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.
+
 2010-10-21  Geert Bosch  <bosch@adacore.com>
 
 	* urealp.adb (UR_Write): Write hexadecimal constants with exponent 1 as

gcc/ada/einfo.adb

@@ -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??");

gcc/ada/elists.adb

@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1992-2009, Free Software Foundation, Inc.         --
+--          Copyright (C) 1992-2010, Free Software Foundation, Inc.         --
 --                                                                          --
 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
 -- terms of the  GNU General Public License as published  by the Free Soft- --
@@ -389,7 +389,6 @@ package body Elists is
       --  Case of removing only element in the list
 
       if Elmts.Table (Nxt).Next in Elist_Range then
-
          pragma Assert (Nxt = Elmt);
 
          Elists.Table (List).First := No_Elmt;

gcc/ada/exp_ch3.adb

@@ -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,

gcc/ada/exp_ch4.adb

@@ -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);

gcc/ada/exp_util.adb

@@ -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)

gcc/ada/par-prag.adb

@@ -1205,6 +1205,7 @@ begin
            Pragma_Persistent_BSS                |
            Pragma_Postcondition                 |
            Pragma_Precondition                  |
+           Pragma_Predicate                     |
            Pragma_Preelaborate                  |
            Pragma_Preelaborate_05               |
            Pragma_Priority                      |

gcc/ada/sem_ch13.adb

@@ -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 :=

gcc/ada/sem_ch6.adb

@@ -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,

gcc/ada/sem_prag.adb

@@ -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,

gcc/ada/snames.ads-tmpl

@@ -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,