Patchwork [Ada] Next step in implementation of predicates

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

Comments

Arnaud Charlet - Oct. 21, 2010, 10:43 a.m.
This patch is the next step in implementation of predicates, and finally
things are starting to work, although there is more to be done. The
following test compiled with -gnata12 executes with no output showing
predicates working for membership tests, and being properly tested for
assignments and subprogram calls.

     1. with Ada.Assertions; use Ada.Assertions;
     2. procedure Simple_Test_Predicates is
     3.
     4.    type Color is (Red, Orange, Yellow, Green, Blue, Indigo, Violet);
     5.    subtype RGB is Color with
     6.      Predicate => RGB = Red or RGB in Green .. Blue;
     7.
     8.    Var : RGB := Red;
     9.
    10.    procedure P (X : RGB) is
    11.    begin
    12.       null;
    13.    end P;
    14.
    15. begin
    16.    pragma Assert (Red in RGB);
    17.    pragma Assert (Blue in RGB);
    18.    pragma Assert (Orange not in RGB);
    19.
    20.    pragma Assert (Red in RGB'Base);
    21.    pragma Assert (Blue in RGB'Base);
    22.    pragma Assert (Orange in RGB'Base);
    23.
    24.    begin
    25.       Var := Yellow;
    26.       raise Program_Error;
    27.    exception
    28.       when Assertion_Error =>
    29.          null; -- OK
    30.    end;
    31.
    32.    begin
    33.       P(Yellow);
    34.       raise Program_Error;
    35.    exception
    36.       when Assertion_Error =>
    37.          null; -- OK
    38.    end;
    39. end Simple_Test_Predicates;

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

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

	* checks.ads, checks.adb (Apply_Predicate_Check): New procedure
	Minor code reorganization.
	* einfo.adb (Has_Predicates): Fix assertion.
	* exp_ch13.adb (Build_Predicate_Function): Move from Sem_Ch13 spec to
	Exp_Ch13 body.
	(Expand_N_Freeze_Entity): Call build predicate function.
	* exp_ch4.adb (Expand_N_Type_Conversion): Add predicate check.
	* exp_ch5.adb (Expand_N_Assignment_Statement): Add predicate check.
	* exp_prag.adb (Expand_Pragma_Check): Use all lower case for name of
	check.
	* freeze.adb (Freeze_Entity): Move building of predicate function to
	Exp_Ch13.
	* sem_ch13.adb (Build_Predicate_Function): Move from Sem_Ch13 to
	Exp_Ch13.
	* sem_ch13.ads (Build_Predicate_Function): Move from Sem_Ch13 to
	Exp_Ch13.
	* sem_ch3.adb (Analyze_Declarations): Remove call to build predicate
	function.
	* sem_res.adb (Resolve_Actuals): Apply predicate check.

Patch

Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb	(revision 165758)
+++ exp_ch5.adb	(working copy)
@@ -1626,6 +1626,10 @@  package body Exp_Ch5 is
          Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
       end if;
 
+      --  Generate predicate check if required
+
+      Apply_Predicate_Check (Rhs, Typ);
+
       --  Check for a special case where a high level transformation is
       --  required. If we have either of:
 
Index: exp_prag.adb
===================================================================
--- exp_prag.adb	(revision 165755)
+++ exp_prag.adb	(working copy)
@@ -294,7 +294,7 @@  package body Exp_Prag is
       --  where Str is the message if one is present, or the default of
       --  name failed at file:line if no message is given (the "name failed
       --  at" is omitted for name = Assertion, since it is redundant, given
-      --  that the name of the exception is Assert_Failure.
+      --  that the name of the exception is Assert_Failure.)
 
       --  An alternative expansion is used when the No_Exception_Propagation
       --  restriction is active and there is a local Assert_Failure handler.
@@ -353,22 +353,18 @@  package body Exp_Prag is
                Msg_Loc : constant String := Build_Location_String (Loc);
 
             begin
+               Name_Len := 0;
+
                --  For Assert, we just use the location
 
                if Nam = Name_Assertion then
-                  Name_Len := 0;
+                  null;
 
-                  --  For any check except Precondition/Postcondition, the
-                  --  string is "xxx failed at yyy" where xxx is the name of
-                  --  the check with current source file casing.
-
-               elsif Nam /= Name_Precondition
-                       and then
-                     Nam /= Name_Postcondition
-               then
-                  Get_Name_String (Nam);
-                  Set_Casing (Identifier_Casing (Current_Source_File));
-                  Add_Str_To_Name_Buffer (" failed at ");
+               --  For predicate, we generate the string "predicate failed
+               --  at yyy". We prefer all lower case for predicate.
+
+               elsif Nam = Name_Predicate then
+                  Add_Str_To_Name_Buffer ("predicate failed at ");
 
                --  For special case of Precondition/Postcondition the string is
                --  "failed xx from yy" where xx is precondition/postcondition
@@ -376,10 +372,21 @@  package body Exp_Prag is
                --  that the failure is not at the point of occurrence of the
                --  pragma, unlike the other Check cases.
 
-               else
+               elsif Nam = Name_Precondition
+                       or else
+                     Nam = Name_Postcondition
+               then
                   Get_Name_String (Nam);
                   Insert_Str_In_Name_Buffer ("failed ", 1);
                   Add_Str_To_Name_Buffer (" from ");
+
+               --  For all other checks, the string is "xxx failed at yyy"
+               --  where xxx is the check name with current source file casing.
+
+               else
+                  Get_Name_String (Nam);
+                  Set_Casing (Identifier_Casing (Current_Source_File));
+                  Add_Str_To_Name_Buffer (" failed at ");
                end if;
 
                --  In all cases, add location string
Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165764)
+++ sem_ch3.adb	(working copy)
@@ -17205,41 +17205,11 @@  package body Sem_Ch3 is
          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.
+      --  Propagate predicates to full type
 
       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;
+         Set_Predicate_Function (Priv_T, Predicate_Function (Full_T));
+         Set_Has_Predicates (Priv_T);
       end if;
    end Process_Full_View;
 
Index: einfo.adb
===================================================================
--- einfo.adb	(revision 165764)
+++ 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_Function);
+      pragma Assert (Is_Type (Id) or else Is_Subprogram (Id));
       return Flag250 (Id);
    end Has_Predicates;
 
Index: checks.adb
===================================================================
--- checks.adb	(revision 165755)
+++ checks.adb	(working copy)
@@ -997,10 +997,15 @@  package body Checks is
       Desig_Typ : Entity_Id;
 
    begin
+      --  No checks inside a generic (check the instantiations)
+
       if Inside_A_Generic then
          return;
+      end if;
+
+      --  Apply required constaint checks
 
-      elsif Is_Scalar_Type (Typ) then
+      if Is_Scalar_Type (Typ) then
          Apply_Scalar_Range_Check (N, Typ);
 
       elsif Is_Array_Type (Typ) then
@@ -1748,6 +1753,20 @@  package body Checks is
         (Ck_Node, Target_Typ, Source_Typ, Do_Static => False);
    end Apply_Length_Check;
 
+   ---------------------------
+   -- Apply_Predicate_Check --
+   ---------------------------
+
+   procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id) is
+   begin
+      if Etype (N) /= Typ
+        and then Present (Predicate_Function (Typ))
+      then
+         Insert_Action (N,
+           Make_Predicate_Check (Typ, Duplicate_Subexpr (N)));
+      end if;
+   end Apply_Predicate_Check;
+
    -----------------------
    -- Apply_Range_Check --
    -----------------------
Index: checks.ads
===================================================================
--- checks.ads	(revision 165755)
+++ checks.ads	(working copy)
@@ -6,7 +6,7 @@ 
 --                                                                          --
 --                                 S p e c                                  --
 --                                                                          --
---          Copyright (C) 1992-2008, 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- --
@@ -134,10 +134,10 @@  package Checks is
      (N          : Node_Id;
       Typ        : Entity_Id;
       No_Sliding : Boolean := False);
-   --  Top-level procedure, calls all the others depending on the class of Typ.
-   --  Checks that expression N satisfies the constraint of type Typ.
-   --  No_Sliding is only relevant for constrained array types, if set to True,
-   --  it checks that indexes are in range.
+   --  Top-level procedure, calls all the others depending on the class of
+   --  Typ. Checks that expression N satisfies the constraint of type Typ.
+   --  No_Sliding is only relevant for constrained array types, if set to
+   --  True, it checks that indexes are in range.
 
    procedure Apply_Discriminant_Check
      (N   : Node_Id;
@@ -153,6 +153,11 @@  package Checks is
    --  formals, the check is peformed only if the corresponding actual is
    --  constrained, i.e., whether Lhs'Constrained is True.
 
+   procedure Apply_Predicate_Check (N : Node_Id; Typ : Entity_Id);
+   --  N is an expression to which a predicate check may need to be applied
+   --  for Typ, if Typ has a predicate function. The check is applied only
+   --  if the type of N does not match Typ.
+
    function Build_Discriminant_Checks
      (N     : Node_Id;
       T_Typ : Entity_Id)
Index: freeze.adb
===================================================================
--- freeze.adb	(revision 165764)
+++ freeze.adb	(working copy)
@@ -3787,28 +3787,6 @@  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: sem_res.adb
===================================================================
--- sem_res.adb	(revision 165760)
+++ sem_res.adb	(working copy)
@@ -3648,6 +3648,19 @@  package body Sem_Res is
             --  any analysis. More thought required about this ???
 
             if Ekind_In (F, E_In_Parameter, E_In_Out_Parameter) then
+
+               --  Apply predicate checks, unless this is a call to the
+               --  predicate check function itself, which would cause an
+               --  infinite recursion.
+
+               if not (Ekind (Nam) = E_Function
+                        and then Has_Predicates (Nam))
+               then
+                  Apply_Predicate_Check (A, F_Typ);
+               end if;
+
+               --  Apply required constraint checks
+
                if Is_Scalar_Type (Etype (A)) then
                   Apply_Scalar_Range_Check (A, F_Typ);
 
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 165764)
+++ exp_ch4.adb	(working copy)
@@ -8767,7 +8767,6 @@  package body Exp_Ch4 is
       --  this case, see Handle_Changed_Representation.
 
       elsif Is_Array_Type (Target_Type) then
-
          if Is_Constrained (Target_Type) then
             Apply_Length_Check (Operand, Target_Type);
          else
@@ -8933,8 +8932,20 @@  package body Exp_Ch4 is
 
       --  Here at end of processing
 
-      <<Done>>
-         null;
+   <<Done>>
+      --  Apply predicate check if required. Note that we can't just call
+      --  Apply_Predicate_Check here, because the type looks right after
+      --  the conversion and it would omit the check. The Comes_From_Source
+      --  guard is necessary to prevent infinite recursions when we generate
+      --  internal conversions for the purpose of checking predicates.
+
+      if Present (Predicate_Function (Target_Type))
+        and then Target_Type /= Operand_Type
+        and then Comes_From_Source (N)
+      then
+         Insert_Action (N,
+           Make_Predicate_Check (Target_Type, Duplicate_Subexpr (N)));
+      end if;
    end Expand_N_Type_Conversion;
 
    -----------------------------------
Index: exp_ch13.adb
===================================================================
--- exp_ch13.adb	(revision 165755)
+++ exp_ch13.adb	(working copy)
@@ -26,6 +26,7 @@ 
 with Atree;    use Atree;
 with Checks;   use Checks;
 with Einfo;    use Einfo;
+with Elists;   use Elists;
 with Exp_Ch3;  use Exp_Ch3;
 with Exp_Ch6;  use Exp_Ch6;
 with Exp_Imgv; use Exp_Imgv;
@@ -37,6 +38,8 @@  with Nmake;    use Nmake;
 with Opt;      use Opt;
 with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
+with Sem_Aux;  use Sem_Aux;
+with Sem_Ch3;  use Sem_Ch3;
 with Sem_Ch7;  use Sem_Ch7;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Eval; use Sem_Eval;
@@ -50,6 +53,308 @@  with Validsw;  use Validsw;
 
 package body Exp_Ch13 is
 
+   -----------------------
+   -- Local Subprograms --
+   -----------------------
+
+   procedure Build_Predicate_Function
+     (Typ   : Entity_Id;
+      FDecl : out Node_Id;
+      FBody : out Node_Id);
+   --  If Typ has predicates (indicated by Has_Predicates being set for Typ,
+   --  then either there are pragma Invariant entries on the rep chain for the
+   --  type (note that Predicate aspects are converted to pragam Predicate), or
+   --  there are inherited aspects from a parent type, or ancestor subtypes,
+   --  or interfaces. This procedure builds the spec and body for the Predicate
+   --  function that tests these predicates, returning them in PDecl and Pbody
+   --  and setting Predicate_Procedure for Typ. In some error situations no
+   --  procedure is built, in which case PDecl/PBody are empty on return.
+
+   ------------------------------
+   -- Build_Predicate_Function --
+   ------------------------------
+
+   --  The procedure that is constructed here has the form
+
+   --  function typPredicate (Ixxx : typ) return Boolean is
+   --  begin
+   --     return
+   --        exp1 and then exp2 and then ...
+   --        and then typ1Predicate (typ1 (Ixxx))
+   --        and then typ2Predicate (typ2 (Ixxx))
+   --        and then ...;
+   --  end typPredicate;
+
+   --  Here exp1, and exp2 are expressions from Predicate pragmas. Note that
+   --  this is the point at which these expressions get analyzed, providing the
+   --  required delay, and typ1, typ2, are entities from which predicates are
+   --  inherited. Note that we do NOT generate Check pragmas, that's because we
+   --  use this function even if checks are off, e.g. for membership tests.
+
+   procedure Build_Predicate_Function
+     (Typ   : Entity_Id;
+      FDecl : out Node_Id;
+      FBody : out Node_Id)
+   is
+      Loc  : constant Source_Ptr := Sloc (Typ);
+      Spec : Node_Id;
+      SId  : Entity_Id;
+
+      Expr : Node_Id;
+      --  This is the expression for the return statement in the function. It
+      --  is build by connecting the component predicates with AND THEN.
+
+      procedure Add_Call (T : Entity_Id);
+      --  Includes a call 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;
+
    ------------------------------------------
    -- Expand_N_Attribute_Definition_Clause --
    ------------------------------------------
@@ -414,6 +719,26 @@  package body Exp_Ch13 is
          Rewrite (N, Make_Null_Statement (Sloc (N)));
       end if;
 
+      --  If freezing a type entity which has predicates, this is where we
+      --  build and insert the predicate function for the type.
+
+      if Is_Type (E) and then Has_Predicates (E) then
+         declare
+            FDecl : Node_Id;
+            FBody : Node_Id;
+
+         begin
+            Build_Predicate_Function (E, FDecl, FBody);
+
+            if Present (FDecl) then
+               Insert_After (N, FBody);
+               Insert_After (N, FDecl);
+            end if;
+         end;
+      end if;
+
+      --  Pop scope if we intalled one for the analysis
+
       if In_Other_Scope then
          if Ekind (Current_Scope) = E_Package then
             End_Package_Scope (E_Scope);
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 165764)
+++ sem_ch13.adb	(working copy)
@@ -3756,291 +3756,6 @@  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 165764)
+++ sem_ch13.ads	(working copy)
@@ -64,19 +64,6 @@  package Sem_Ch13 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
    --  N. It is called at freeze time after adjustment of component clause bit