diff mbox

[Ada] Fixes to predicate handling

Message ID 20101026104442.GA7669@adacore.com
State New
Headers show

Commit Message

Arnaud Charlet Oct. 26, 2010, 10:44 a.m. UTC 
This patch fixes a number of problems in predicate handling,
including those related to qualification of the type name,
and use with variants and discriminants. The following test
compiled with -gnata12 -gnatld7 -gnatj60 compiles clean with
the one info message, and generates no output when run.

Compiling: test_predicates_variant-main.adb

     1. with Test_Predicates_Variant.Acc;
     2. use Test_Predicates_Variant.Acc;
     3. procedure Test_Predicates_Variant.Main is
     4.    --  This test should run silently
     5.
     6.    X1 : RGB;
     7.    -- OK; predicate not checked
     8.
     9.    X2 : Another_Color;
    10.    -- OK; predicate not checked
    11.
    12.    X3 : No_Defaults(Kind => Red);
    13.    -- OK; no predicate
    14.
    15.    X4 : No_Defaults_P(Kind => Red);
    16.    -- OK; predicate not checked
    17.
    18.    X5 : Defaults;
    19.    -- OK; no predicate
    20.
    21.    X6 : RGB := Not_Another_One;
    22.    -- OK; predicate is True
    23.
    24.    X7 : No_Defaults := Bad;
    25.    -- OK; no predicate
    26.
    27.    X8 : No_Defaults_P := Good;
    28.    -- OK; predicate is True
    29.
    30.    X9 : Defaults := Bad;
    31.    -- OK; no predicate
    32.
    33.    X10 : Defaults_P := Good;
    34.    -- OK; predicate is True
    35.
    36.    Even_Var_1 : Even;
    37.    -- OK; predicate not checked
    38.
    39.    Even_Var_2 : Even := 100;
    40.    -- OK; predicate is True
    41.
    42. begin
    43.
    44.    begin
    45.       Even_Var_1 := 1;
    46.       raise Program_Error;
    47.       -- Predicate should have failed
    48.    exception
    49.       when Assertion_Error =>
    50.          null; -- OK
    51.    end;
    52.
    53.    Even_Var_1 := 0; -- OK; predicate is True
    54.
    55.    begin
    56.       declare
    57.          Even_Var_3 : Even := Even_Var_2 + 1;
    58.       begin
    59.          raise Program_Error;
    60.          -- Predicate should have failed
    61.       end;
    62.    exception
    63.       when Assertion_Error =>
    64.          null; -- OK
    65.    end;
    66.
    67.    ----------------
    68.
    69.    begin
    70.       declare
    71.          Var : Another_Color := Not_Another_One;
    72.       begin
    73.          raise Program_Error;
    74.          -- Predicate should have failed
    75.       end;
    76.    exception
    77.       when Assertion_Error =>
    78.          null; -- OK
    79.    end;
    80.
    81.    begin
    82.       declare
    83.          Var : Defaults_P := Bad;
    84.       begin
    85.          raise Program_Error;
    86.          -- Predicate should have failed
    87.       end;
    88.    exception
    89.       when Assertion_Error =>
    90.          null; -- OK
    91.    end;
    92.
    93.    begin
    94.       declare
    95.          Var : No_Defaults_P := Bad;
    96.       begin
    97.          raise Program_Error;
    98.          -- Predicate should have failed
    99.       end;
   100.    exception
   101.       when Assertion_Error =>
   102.          null; -- OK
   103.    end;
   104.
   105.    begin
   106.       declare
   107.          Var : Defaults_P;
   108.          -- Default init violates predicate
   109.       begin
   110.          raise Program_Error;
   111.          -- Predicate should have failed
   112.       end;
   113.    exception
   114.       when Assertion_Error =>
   115.          null; -- OK
   116.    end;
   117.
   118.    X1 := Not_Another_One; -- OK; predicate is True
   119.
   120.    begin
   121.       X2 := Not_Another_One;
   122.       raise Program_Error; -- Predicate should have failed
   123.    exception
   124.       when Assertion_Error =>
   125.          null; -- OK
   126.    end;
   127.
   128.    X3 := Bad; -- OK; no predicate
   129.
   130.    X4 := Good;
   131.    begin
   132.       X4 := Bad;
   133.       raise Program_Error;
   134.       -- Predicate should have failed
   135.    exception
   136.       when Assertion_Error =>
   137.          null; -- OK
   138.    end;
   139.
   140.    X5 := Bad; -- OK; no predicate
   141.
   142.    X6 := Not_Another_One;
   143.    -- OK; predicate is True
   144.
   145.    X7 := Bad; -- OK; no predicate
   146.
   147.    X8 := Good; -- OK; predicate is True
   148.    begin
   149.       X8 := Bad;
   150.       raise Program_Error;
   151.       -- Predicate should have failed
   152.    exception
   153.       when Assertion_Error =>
   154.          null; -- OK
   155.    end;
   156.
   157.    X9 := Bad; -- OK; no predicate
   158.
   159.    X10 := Good; -- OK; predicate is True
   160.    begin
   161.       X10 := Bad;
   162.       raise Program_Error;
   163.       -- Predicate should have failed
   164.    exception
   165.       when Assertion_Error =>
   166.          null; -- OK
   167.    end;
   168.
   169.    ----------------
   170.
   171.    declare
   172.       procedure P (X : Another_Color_Ref) is
   173.       begin
   174.          null;
   175.       end P;
   176.
   177.       Var : Ref := new Node(Red);
   178.    begin
   179.       P (Var); -- Violate predicate of 'in' param
   180.       raise Program_Error;
   181.    exception
   182.       when Assertion_Error =>
   183.          null; -- OK
   184.    end;
   185.
   186.    declare
   187.       procedure P (X : out Another_Color_Ref) is
   188.       begin
   189.          null;
   190.          -- Predicate of 'out' param
   191.          -- raises Constraint_Error
   192.       end P;
   193.
   194.       Var : Ref;
   195.    begin
   196.       P (Var);
   197.       raise Program_Error;
   198.    exception
   199.       when Constraint_Error =>
   200.          null; -- OK
   201.    end;
   202.
   203.    declare
   204.       procedure P (X : out Another_Color_Ref) is
   205.       begin
   206.          X := new Node(Orange);
   207.       end P;
   208.
   209.       Var : Ref;
   210.    begin
   211.       P (Var);
   212.       -- OK; don't check predicate on the way 'in'
   213.    end;
   214.
   215.    declare
   216.       procedure P (X : in out Another_Color_Ref) is
   217.       begin
   218.          X := new Node(Orange); -- Can't get here
   219.       end P;
   220.
   221.       Var : Ref;
   222.    begin
   223.       P (Var);
   224.       -- Predicate of 'in out' param
   225.       -- raises Constraint_Error
   226.       raise Program_Error;
   227.    exception
   228.       when Constraint_Error =>
   229.          null; -- OK
   230.    end;
   231.
   232. end Test_Predicates_Variant.Main;

 232 lines: No errors

Compiling: test_predicates_variant.adb

     1.
     2. package body Test_Predicates_Variant is
     3.
     4.    function Not_Another_One return Color is
     5.    begin
     6.       return Result : constant Color := Red do
     7.          pragma Assert (Result in RGB);
     8.          pragma Assert
     9.            (Result not in Another_Color);
    10.       end return;
    11.    end Not_Another_One;
    12.
    13.    function Is_Good
    14.      (X : No_Defaults) return Boolean is
    15.    begin
    16.       return X.Acc /= null;
    17.    end Is_Good;
    18.
    19.    function Good return No_Defaults is
    20.    begin
    21.       return Result : constant No_Defaults
    22.         := (Kind => Red, Comp => 0, Acc => new String'("xxx"))
    23.       do
    24.          pragma Assert (Result in No_Defaults_P);
    25.          pragma Assert (Is_Good (Result));
    26.       end return;
    27.    end Good;
    28.
    29.    function Bad return No_Defaults is
    30.    begin
    31.       return Result : constant No_Defaults
    32.         := (Kind => Red, Comp => 0, Acc => null)
    33.       do
    34.          pragma Assert (Result not in No_Defaults_P);
    35.          pragma Assert (not Is_Good (Result));
    36.       end return;
    37.    end Bad;
    38.
    39.    function Is_Good (X : Defaults) return Boolean is
    40.    begin
    41.       return X.Acc /= null;
    42.    end Is_Good;
    43.
    44.    function Good return Defaults is
    45.    begin
    46.       return Result : constant Defaults
    47.         := (Comp => 0, Acc => new String'("xxx"))
    48.       do
    49.          pragma Assert (Is_Good (Result));
    50.          pragma Assert (Result in Defaults_P);
    51.       end return;
    52.    end Good;
    53.
    54.    function Bad return Defaults is
    55.    begin
    56.       return Result : constant Defaults
    57.         := (Comp => 0, Acc => null)
    58.       do
    59.          pragma Assert (not Is_Good (Result));
    60.          pragma Assert (Result not in Defaults_P);
    61.       end return;
    62.    end Bad;
    63.
    64. end Test_Predicates_Variant;

Compiling: test_predicates_variant.ads

     1. with Ada.Assertions; use Ada.Assertions;
     2. package Test_Predicates_Variant is
     3.
     4.    type String_Ref is access all String;
     5.
     6.    type Even is range 0 .. Integer'Last with
     7.      Predicate => (Even mod 2) = 0;
     8.
     9.    type Color is
    10.      (Red, Orange, Yellow, Green, Blue, Indigo, Violet);
    11.    subtype RGB is Color with
    12.      Predicate => RGB = Red or RGB in Green .. Blue;
    13.    subtype Other_Color is Color with
    14.      Predicate => Other_Color not in RGB;
    15.
    16.    subtype Another_Color is Other_Color;
                   |
        >>> info: "Another_Color" inherits predicate from "Other_Color" at line 13

    17.    function Not_Another_One return Color;
    18.    -- Returns a value that violates
    19.    -- Another_Color's predicate
    20.
    21.    type No_Defaults(Kind: Color) is
    22.       record
    23.          case Kind is
    24.             when Red =>
    25.                Comp : Integer;
    26.                Acc : String_Ref;
    27.                -- Default 'null' default doesn't count!
    28.             when others => null;
    29.          end case;
    30.       end record;
    31.
    32.    subtype No_Defaults_P is No_Defaults with
    33.      Predicate => Is_Good (No_Defaults_P);
    34.
    35.    function Is_Good (X : No_Defaults) return Boolean;
    36.    function Good return No_Defaults;
    37.    function Bad return No_Defaults;
    38.    -- Is_Good(Good) is True; Is_Good(Bad) is False.
    39.
    40.    type Defaults is
    41.       record
    42.          Comp : Integer := 0;
    43.          Acc : String_Ref := null;
    44.       end record;
    45.
    46.    subtype Defaults_P is Defaults with
    47.      Predicate => Is_Good (Defaults_P);
    48.
    49.    function Is_Good (X : Defaults) return Boolean;
    50.    function Good return Defaults;
    51.    function Bad return Defaults;
    52.
    53. end Test_Predicates_Variant;


Compiling: test_predicates_variant-acc.ads

     1. package Test_Predicates_Variant.Acc is
     2.
     3.    type Node (Discrim : Color) is
     4.       record
     5.          case Discrim is
     6.             when Red =>
     7.                Red_Comp : Integer;
     8.             when others =>
     9.                Others_Color_Comp : Integer;
    10.          end case;
    11.       end record;
    12.
    13.    type Ref is access all Node;
    14.    subtype RGB_Ref is Ref with
    15.      Predicate => RGB_Ref.all.Discrim in RGB;
    16.    subtype Another_Color_Ref is Ref with
    17.      Predicate =>
    18.        Another_Color_Ref.all.Discrim
    19.          in Another_Color;
    20.
    21. end Test_Predicates_Variant.Acc;

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

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

	* exp_ch3.adb (Expand_N_Object_Declaration): Move generation of
	predicate check to analyzer, since too much rewriting occurs in the
	analyzer.
	* sem_ch13.adb (Build_Predicate_Function): Change calling sequence, and
	change the order in which things are done to fix several errors in
	dealing with qualification of the type name.
	(Build_Static_Predicate): Built static predicate after full analysis
	of the body. This is necessary to fix several problems.
	* sem_ch3.adb (Analyze_Object_Declaration): Move predicate check here
	from expander, since too much expansion occurs in the analyzer to leave
	it that late.
	(Analyze_Object_Declaration): Change parameter Include_Null to new name
	Include_Implicit in Is_Partially_Initialized_Type call.
	(Analyze_Subtype_Declaration): Make sure predicates are proapagated in
	some strange cases of internal subtype generation.
	* sem_util.ads, sem_util.adb (Is_Partially_Initialized_Type): Change
	Include_Null to Include_Implicit, now includes the case of
	discriminants.
diff mbox

Patch

Index: sem_ch3.adb
===================================================================
--- sem_ch3.adb	(revision 165935)
+++ sem_ch3.adb	(working copy)
@@ -3077,6 +3077,27 @@  package body Sem_Ch3 is
          end if;
       end if;
 
+      --  Deal with predicate check before we start to do major rewriting.
+      --  it is OK to initialize and then check the initialized value, since
+      --  the object goes out of scope if we get a predicate failure. Note
+      --  that we do this in the analyzer and not the expander because the
+      --  analyzer does some substantial rewriting in some cases.
+
+      --  We need a predicate check if the type has predicates, and if either
+      --  there is an initializing expression, or for default initialization
+      --  when we have at least one case of an explicit default initial value.
+
+      if not Suppress_Assignment_Checks (N)
+        and then Present (Predicate_Function (T))
+        and then
+          (Present (E)
+            or else
+              Is_Partially_Initialized_Type (T, Include_Implicit => False))
+      then
+         Insert_After (N,
+           Make_Predicate_Check (T, New_Occurrence_Of (Id, Loc)));
+      end if;
+
       --  Case of unconstrained type
 
       if Is_Indefinite_Subtype (T) then
@@ -3846,7 +3867,13 @@  package body Sem_Ch3 is
       --  If ancestor has predicates then so does the subtype, and in addition
       --  we must delay the freeze to properly arrange predicate inheritance.
 
-      if Has_Predicates (T) then
+      --  The Ancestor_Type test is a big kludge, there seem to be cases in
+      --  which T = ID, so the above tests and assignments do nothing???
+
+      if Has_Predicates (T)
+        or else (Present (Ancestor_Subtype (T))
+                   and then Has_Predicates (Ancestor_Subtype (T)))
+      then
          Set_Has_Predicates (Id);
          Set_Has_Delayed_Freeze (Id);
       end if;
Index: sem_util.adb
===================================================================
--- sem_util.adb	(revision 165935)
+++ sem_util.adb	(working copy)
@@ -6859,22 +6859,22 @@  package body Sem_Util is
    -----------------------------------
 
    function Is_Partially_Initialized_Type
-     (Typ          : Entity_Id;
-      Include_Null : Boolean := True) return Boolean
+     (Typ              : Entity_Id;
+      Include_Implicit : Boolean := True) return Boolean
    is
    begin
       if Is_Scalar_Type (Typ) then
          return False;
 
       elsif Is_Access_Type (Typ) then
-         return Include_Null;
+         return Include_Implicit;
 
       elsif Is_Array_Type (Typ) then
 
          --  If component type is partially initialized, so is array type
 
          if Is_Partially_Initialized_Type
-              (Component_Type (Typ), Include_Null)
+              (Component_Type (Typ), Include_Implicit)
          then
             return True;
 
@@ -6888,9 +6888,10 @@  package body Sem_Util is
 
       elsif Is_Record_Type (Typ) then
 
-         --  A discriminated type is always partially initialized
+         --  A discriminated type is always partially initialized if in
+         --  all mode
 
-         if Has_Discriminants (Typ) then
+         if Has_Discriminants (Typ) and then Include_Implicit then
             return True;
 
          --  A tagged type is always partially initialized
@@ -6929,7 +6930,7 @@  package body Sem_Util is
                      --  initialized, then the enclosing record type is also.
 
                      elsif Is_Partially_Initialized_Type
-                             (Etype (Ent), Include_Null)
+                             (Etype (Ent), Include_Implicit)
                      then
                         return True;
                      end if;
@@ -6969,7 +6970,7 @@  package body Sem_Util is
             if No (U) then
                return True;
             else
-               return Is_Partially_Initialized_Type (U, Include_Null);
+               return Is_Partially_Initialized_Type (U, Include_Implicit);
             end if;
          end;
 
Index: sem_util.ads
===================================================================
--- sem_util.ads	(revision 165935)
+++ sem_util.ads	(working copy)
@@ -769,17 +769,20 @@  package Sem_Util is
    --  conversions and hence variables.
 
    function Is_Partially_Initialized_Type
-     (Typ          : Entity_Id;
-      Include_Null : Boolean := True) return Boolean;
+     (Typ              : Entity_Id;
+      Include_Implicit : Boolean := True) return Boolean;
    --  Typ is a type entity. This function returns true if this type is partly
    --  initialized, meaning that an object of the type is at least partly
    --  initialized (in particular in the record case, that at least one
    --  component has an initialization expression). Note that initialization
    --  resulting from the use of pragma Normalized_Scalars does not count.
-   --  Include_Null controls the handling of access types, and components of
-   --  access types not explicitly initialized. If set to True, the default,
-   --  default initialization of access types counts as making the type be
-   --  partially initialized. If False, this does not count.
+   --  Include_Implicit controls whether implicit initialiation of access
+   --  values to null, and of discriminant values, is counted as making the
+   --  type be partially initialized. For the default setting of True, these
+   --  implicit cases do count, and discriminated types or types containing
+   --  access values not explicitly initialized will return True. Otherwise
+   --  if Include_Implicit is False, these cases do not count as making the
+   --  type be partially initialied.
 
    function Is_Potentially_Persistent_Type (T : Entity_Id) return Boolean;
    --  Determines if type T is a potentially persistent type. A potentially
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 165935)
+++ sem_ch13.adb	(working copy)
@@ -44,6 +44,7 @@  with Rtsfind;  use Rtsfind;
 with Sem;      use Sem;
 with Sem_Aux;  use Sem_Aux;
 with Sem_Ch3;  use Sem_Ch3;
+with Sem_Ch6;  use Sem_Ch6;
 with Sem_Ch8;  use Sem_Ch8;
 with Sem_Eval; use Sem_Eval;
 with Sem_Res;  use Sem_Res;
@@ -77,18 +78,15 @@  package body Sem_Ch13 is
    --  inherited from a derived type that is no longer appropriate for the
    --  new Esize value. In this case, we reset the Alignment to unknown.
 
-   procedure Build_Predicate_Function
-     (Typ   : Entity_Id;
-      FDecl : out Node_Id;
-      FBody : out Node_Id);
+   procedure Build_Predicate_Function (Typ : Entity_Id; N : 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.
+   --  there are inherited aspects from a parent type, or ancestor subtypes.
+   --  This procedure builds the spec and body for the Predicate function that
+   --  tests these predicates. N is the freeze node for the type. The spec of
+   --  the function is inserted before the freeze node, and the body of the
+   --  funtion is inserted after the freeze node.
 
    procedure Build_Static_Predicate
      (Typ  : Entity_Id;
@@ -3070,18 +3068,7 @@  package body Sem_Ch13 is
       --  If we have a type with predicates, build predicate function
 
       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;
+         Build_Predicate_Function (E, N);
       end if;
    end Analyze_Freeze_Entity;
 
@@ -3839,14 +3826,15 @@  package body Sem_Ch13 is
    --  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
+   procedure Build_Predicate_Function (Typ : Entity_Id; N : Node_Id) is
       Loc  : constant Source_Ptr := Sloc (Typ);
       Spec : Node_Id;
       SId  : Entity_Id;
+      FDecl : Node_Id;
+      FBody : Node_Id;
+
+      TName : constant Name_Id := Chars (Typ);
+      --  Name of the type, used for replacement in predicate expression
 
       Expr : Node_Id;
       --  This is the expression for the return statement in the function. It
@@ -3898,11 +3886,14 @@  package body Sem_Ch13 is
             --  Output info message on inheritance if required. Note we do not
             --  give this information for generic actual types, since it is
             --  unwelcome noise in that case in instantiations. We also
-            --  generally suppress the message in instantiations.
+            --  generally suppress the message in instantiations, and also
+            --  if it involves internal names.
 
             if Opt.List_Inherited_Aspects
               and then not Is_Generic_Actual_Type (Typ)
               and then Instantiation_Depth (Sloc (Typ)) = 0
+              and then not Is_Internal_Name (Chars (T))
+              and then not Is_Internal_Name (Chars (Typ))
             then
                Error_Msg_Sloc := Sloc (Predicate_Function (T));
                Error_Msg_Node_2 := T;
@@ -3924,34 +3915,102 @@  package body Sem_Ch13 is
          --  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.
+         --  Traverse an expression changing every occurrence of an identifier
+         --  whose name is TName with a reference to the object argument.
 
          ------------------
          -- Replace_Node --
          ------------------
 
          function Replace_Node (N : Node_Id) return Traverse_Result is
+            S : Entity_Id;
+            P : Node_Id;
+
          begin
-            --  Case of entity name referencing the type
+            --  Case of identifier
 
-            if Is_Entity_Name (N) and then Entity (N) = Typ then
+            if Nkind (N) = N_Identifier then
 
-               --  Replace with object
+               --  If not the type name, all done with this node
 
-               Rewrite (N,
-                 Make_Identifier (Loc,
-                   Chars => Object_Name));
+               if Chars (N) /= TName then
+                  return Skip;
 
-               --  All done with this node
+               --  Otherwise do the replacement
 
-               return Skip;
+               else
+                  goto Do_Replace;
+               end if;
+
+               --  Case of selected component (which is what a qualification
+               --  looks like in the unanalyzed tree, which is what we have.
+
+            elsif Nkind (N) = N_Selected_Component then
+
+               --  If selector name is not our type, keeping going (we might
+               --  still have an occurrence of the type in the prefix).
+
+               if Nkind (Selector_Name (N)) /= N_Identifier
+                 or else Chars (Selector_Name (N)) /= TName
+               then
+                  return OK;
+
+               --  Selector name is our type, check qualification
+
+               else
+                  --  Loop through scopes and prefixes, doing comparison
+
+                  S := Current_Scope;
+                  P := Prefix (N);
+                  loop
+                     --  Continue if no more scopes or scope with no name
+
+                     if No (S) or else Nkind (S) not in N_Has_Chars then
+                        return OK;
+                     end if;
+
+                     --  Do replace if prefix is an identifier matching the
+                     --  scope that we are currently looking at.
+
+                     if Nkind (P) = N_Identifier
+                       and then Chars (P) = Chars (S)
+                     then
+                        goto Do_Replace;
+                     end if;
+
+                     --  Go check scope above us if prefix is itself of the
+                     --  form of a selected component, whose selector matches
+                     --  the scope we are currently looking at.
+
+                     if Nkind (P) = N_Selected_Component
+                       and then Nkind (Selector_Name (P)) = N_Identifier
+                       and then Chars (Selector_Name (P)) = Chars (S)
+                     then
+                        S := Scope (S);
+                        P := Prefix (P);
 
-            --  Not an occurrence of the type entity, keep going
+                     --  For anything else, we don't have a match, so keep on
+                     --  going, there are still some weird cases where we may
+                     --  still have a replacement within the prefix.
+
+                     else
+                        return OK;
+                     end if;
+                  end loop;
+               end if;
+
+            --  Continue for any other node kind
 
             else
                return OK;
             end if;
+
+         <<Do_Replace>>
+
+            --  Replace with object
+
+            Rewrite (N, Make_Identifier (Loc, Chars => Object_Name));
+            return Skip;
          end Replace_Node;
 
       --  Start of processing for Add_Predicates
@@ -3975,17 +4034,8 @@  package body Sem_Ch13 is
                   --  We have a match, this entry is for our subtype
 
                   --  First 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 recognized
-                  --  as legitimate.
-
-                  Set_OK_To_Reference (Typ, True);
-                  Preanalyze_Spec_Expression (Arg2, Standard_Boolean);
-                  Set_OK_To_Reference (Typ, False);
+                  --  the type with references to the object.
+
                   Replace_Type (Arg2);
 
                   --  OK, replacement complete, now we can add the expression
@@ -4014,8 +4064,6 @@  package body Sem_Ch13 is
       --  Initialize for construction of statement list
 
       Expr  := Empty;
-      FDecl := Empty;
-      FBody := Empty;
 
       --  Return if already built or if type does not have predicates
 
@@ -4043,16 +4091,6 @@  package body Sem_Ch13 is
 
       if Present (Expr) then
 
-         --  Deal with static predicate case
-
-         if Ekind_In (Typ, E_Enumeration_Subtype,
-                           E_Modular_Integer_Subtype,
-                           E_Signed_Integer_Subtype)
-           and then Is_Static_Subtype (Typ)
-         then
-            Build_Static_Predicate (Typ, Expr, Object_Name);
-         end if;
-
          --  Build function declaration
 
          pragma Assert (Has_Predicates (Typ));
@@ -4073,9 +4111,7 @@  package body Sem_Ch13 is
              Result_Definition        =>
                New_Occurrence_Of (Standard_Boolean, Loc));
 
-         FDecl :=
-           Make_Subprogram_Declaration (Loc,
-             Specification => Spec);
+         FDecl := Make_Subprogram_Declaration (Loc, Specification => Spec);
 
          --  Build function body
 
@@ -4104,6 +4140,21 @@  package body Sem_Ch13 is
                  Statements => New_List (
                    Make_Simple_Return_Statement (Loc,
                      Expression => Expr))));
+
+         --  Insert declaration before freeze node and body after
+
+         Insert_Before_And_Analyze (N, FDecl);
+         Insert_After_And_Analyze  (N, FBody);
+
+         --  Deal with static predicate case
+
+         if Ekind_In (Typ, E_Enumeration_Subtype,
+                           E_Modular_Integer_Subtype,
+                           E_Signed_Integer_Subtype)
+           and then Is_Static_Subtype (Typ)
+         then
+            Build_Static_Predicate (Typ, Expr, Object_Name);
+         end if;
       end if;
    end Build_Predicate_Function;
 
@@ -4908,6 +4959,13 @@  package body Sem_Ch13 is
                    Left_Opnd    => Make_Identifier (Loc, Nam),
                    Right_Opnd   => Empty,
                    Alternatives => New_Alts));
+
+               --  Resolve new expression in function context
+
+               Install_Formals (Predicate_Function (Typ));
+               Push_Scope (Predicate_Function (Typ));
+               Analyze_And_Resolve (Expr, Standard_Boolean);
+               Pop_Scope;
             end if;
          end;
       end;
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb	(revision 165935)
+++ exp_ch3.adb	(working copy)
@@ -4508,25 +4508,6 @@  package body Exp_Ch3 is
          return;
       end if;
 
-      --  Deal with predicate check before we start to do major rewriting.
-      --  it is OK to initialize and then check the initialized value, since
-      --  the object goes out of scope if we get a predicate failure.
-
-      --  We need a predicate check if the type has predicates, and if either
-      --  there is an initializing expression, or for default initialization
-      --  when we have at least one case of an explicit default initial value.
-
-      if not Suppress_Assignment_Checks (N)
-        and then Present (Predicate_Function (Typ))
-        and then
-          (Present (Expr)
-            or else
-              Is_Partially_Initialized_Type (Typ, Include_Null => False))
-      then
-         Insert_After (N,
-           Make_Predicate_Check (Typ, New_Occurrence_Of (Def_Id, Loc)));
-      end if;
-
       --  Force construction of dispatch tables of library level tagged types
 
       if Tagged_Type_Expansion