Patchwork [Ada] Loops through types with static predicates

login
register
mail settings
Submitter Arnaud Charlet
Date Oct. 22, 2010, 2:52 p.m.
Message ID <20101022145224.GA26632@adacore.com>
Download mbox | patch
Permalink /patch/68867/
State New
Headers show

Comments

Arnaud Charlet - Oct. 22, 2010, 2:52 p.m.
This patch implements efficient looping through discrete types
with static predicates. It also cleans up various aspects of
handling of predicates in general. There are three updated
and new tests affected by this patch.

First the test for errors now catches the case of a loop
through a type with a non-static predicate (compiled with
-gnata12 -gnatj60 -gnatld7

     1. procedure Bad_Predicates is
     2.    -- This test should get compile-time errors
     3.
     4.    type Color is
     5.      (Red, Orange, Yellow, Green,
     6.       Blue, Indigo, Violet);
     7.    subtype RGB is Color with
     8.      Predicate =>
     9.        RGB = Red or RGB in Green .. Blue;
    10.    subtype Other_Color is Color with
    11.      Predicate => Other_Color not in RGB;
    12.
    13.    subtype Another_Color is Other_Color;
                   |
        >>> info: "Another_Color" inherits predicate from
            "Other_Color" at line 10

    14.
    15.    type Bad_Array is array
    16.      (Another_Color range <>) of Character;
              |
        >>> subtype "Another_Color" has predicate, not
            allowed as index subtype

    17.    --  ERROR: Subtype with predicate not
    18.    --         allowed as index subtype
    19.
    20.    type OK_Array is array
    21.      (Color range <>) of Character;
    22.
    23.    subtype Bad_Array_Subtype is
    24.      OK_Array (Another_Color);
                       |
        >>> subtype "Another_Color" has predicate, not
            allowed in index constraint

    25.    --  ERROR: Subtype with predicate not
    26.    --         allowed in index_constraint
    27.
    28.    OK : constant OK_Array := (Color => 'x');
    29.
    30.    Bad_Slice : constant OK_Array :=
    31.                  OK (Another_Color);
                             |
        >>> subtype "Another_Color" has predicate, not
            allowed in slice

    32.    --  ERROR: Subtype with predicate not
    33.    --         allowed in slice
    34.
    35.    protected type Prot is
    36.       entry Bad_Family
    37.               (Another_Color) (X : Integer);
                       |
        >>> subtype "Another_Color" has predicate, not
            allowed in entry family

    38.       --  ERROR: Subtype with predicate not
    39.       --         allowed in entry family
    40.    end Prot;
    41.
    42.    protected body Prot is
    43.       entry Bad_Family (for J in Another_Color)
    44.         (X : Integer)
    45.          when True
    46.       is
    47.       begin null; end;
    48.    end Prot;
    49.
    50.    V : Color;
    51.
    52.    procedure Bad_Case (B : Color) is
    53.    begin
    54.       case B is
    55.          when Another_Color => null;
                      |
        >>> cannot use subtype "Another_Color" with
            non-static predicate as case alternative

    56.          when others => null;
    57.       end case;
    58.    end Bad_Case;
    59.
    60.    procedure Bad_Loop is
    61.    begin
    62.       for J in Another_Color loop
                       |
        >>> cannot use subtype "Another_Color" with
            non-static predicate for loop iteration

    63.          null;
    64.       end loop;
    65.    end Bad_Loop;
    66.
    67.    --  Some bad uses within a generic
    68.    --  Generate warnings instead of errors
    69.
    70.    generic
    71.       type Another_Color is (<>);
    72.    package T is
    73.       type Bad_Array is array
    74.         (Another_Color range <>) of Character;
    75.       --  ERROR: Subtype with predicate not
    76.       --         allowed as index subtype
    77.
    78.       subtype Bad_Array_Subtype is
    79.         Bad_Array (Another_Color);
    80.       --  ERROR: Subtype with predicate not
    81.       --         allowed in index_constraint
    82.
    83.       protected type Prot is
    84.          entry Bad_Family
    85.            (Another_Color) (X : Integer);
    86.          --  ERROR: Subtype with predicate not
    87.          --         allowed in entry family
    88.       end Prot;
    89.    end T;
    90.
    91.    package body T is
    92.       protected body Prot is
    93.          entry Bad_Family (for J in Another_Color)
    94.            (X : Integer)
    95.          when True
    96.          is
    97.          begin null; end;
    98.       end Prot;
    99.    end;
   100.
   101.    package TT is new T (Another_Color);
           |
        >>> warning: in instantiation at line 74, subtype
            "Another_Color" has predicate, not allowed as
            index subtype, Program_Error will be raised at
            run time
        >>> warning: in instantiation at line 79, subtype
            "Another_Color" has predicate, not allowed in
            index constraint, Program_Error will be raised
            at run time
        >>> warning: in instantiation at line 85, subtype
            "Another_Color" has predicate, not allowed in
            entry family, Program_Error will be raised at
            run time

   102.
   103. begin
   104.    null;
   105. end Bad_Predicates;

The following test shows looping through a static predicate,
compiled with -gnat12 -gnatld7

     1. with Text_IO; use Text_IO;
     2. procedure Predicate_Loop is
     3.    type Int is range 1 .. 10;
     4.
     5.    subtype StaticP is Int with
     6.       predicate =>
     7.      StaticP in 3 | 5 .. 7 |
     8.                 10 | 5 .. 6 | 6;
     9.
    10. begin
    11.    for J in StaticP loop
    12.       Put_Line ("static:" & J'Img);
    13.    end loop;
    14. end Predicate_Loop;

The output of this test is:

static: 3
static: 5
static: 6
static: 7
static: 10

Finally a small test to make sure we are handling proper
testing of ranges (where we should not do the predicate
test if there is an explicit range), compiled with -gnatld7.

     1. pragma Ada_2012;
     2. with Unchecked_Conversion;
     3. with Text_IO; use Text_IO;
     4. procedure predrange is
     5.    type r is new integer with
     6.      predicate => r mod 2 = 1;
     7.    function UC is new
     8.      Unchecked_Conversion (Integer, r);
     9.    v : r;
    10.    function Ident (X : Integer) return Integer
    11.    is begin return X; end;
    12.
    13. begin
    14.    v := UC (Ident (4));
    15.
    16.    if v in 1 .. 7 then
    17.       Put_Line ("OK");
    18.    else
    19.       Put_Line ("failed 1");
    20.    end if;
    21.
    22.    if v in r then
    23.       Put_Line ("failed");
    24.    else
    25.       Put_Line ("OK");
    26.    end if;
    27. end predrange;

The output is:

OK
OK

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

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

	* checks.adb (Enable_Range_Check): Remove code suppressing range check
	if static predicate present, not needed.
	* exp_attr.adb (Expand_Pred_Succ): Check Suppress_Assignment_Checks flag
	* exp_ch3.adb (Expand_N_Object_Declaration): Check
	Suppress_Assignment_Checks flag.
	* exp_ch4.adb (Expand_N_In): Make some corrections for proper handling
	of ranges when predicates are present.
	* exp_ch5.adb (Expand_Predicated_Loop): New procedure
	(Expand_N_Assignment_Statement): Check Suppress_Assignment_Checks flag
	(Expand_N_Loop_Statement): Handle loops over predicated types
	* sem_case.adb (Analyze_Choices): Remove extra blank in error message.
	* sem_ch13.adb (Build_Predicate_Function.Add_Call): Suppress info
	message for inheritance if within a generic instance, not useful there!
	(Build_Static_Predicate): Optimize test in predicate function
	based on static ranges determined.
	* sem_ch5.adb (Analyze_Iteration_Scheme): Error for loop through
	subtype with non-static predicate.
	* sinfo.ads, sinfo.adb (Suppress_Assignment_Checks): New flag.

Patch

Index: exp_ch5.adb
===================================================================
--- exp_ch5.adb	(revision 165814)
+++ exp_ch5.adb	(working copy)
@@ -107,6 +107,9 @@  package body Exp_Ch5 is
    --  Expand loop over arrays and containers that uses the form "for X of C"
    --  with an optional subtype mark, or "for Y in C".
 
+   procedure Expand_Predicated_Loop (N : Node_Id);
+   --  Expand for loop over predicated subtype
+
    function Make_Tag_Ctrl_Assignment (N : Node_Id) return List_Id;
    --  Generate the necessary code for controlled and tagged assignment, that
    --  is to say, finalization of the target before, adjustment of the target
@@ -1623,16 +1626,21 @@  package body Exp_Ch5 is
          end;
       end if;
 
-      --  First deal with generation of range check if required
+      --  Deal with assignment checks unless suppressed
 
-      if Do_Range_Check (Rhs) then
-         Set_Do_Range_Check (Rhs, False);
-         Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
-      end if;
+      if not Suppress_Assignment_Checks (N) then
+
+         --  First deal with generation of range check if required
 
-      --  Generate predicate check if required
+         if Do_Range_Check (Rhs) then
+            Set_Do_Range_Check (Rhs, False);
+            Generate_Range_Check (Rhs, Typ, CE_Range_Check_Failed);
+         end if;
+
+         --  Then generate predicate check if required
 
-      Apply_Predicate_Check (Rhs, Typ);
+         Apply_Predicate_Check (Rhs, Typ);
+      end if;
 
       --  Check for a special case where a high level transformation is
       --  required. If we have either of:
@@ -2960,8 +2968,9 @@  package body Exp_Ch5 is
    --  2. Deal with while condition for C/Fortran boolean
    --  3. Deal with loops with a non-standard enumeration type range
    --  4. Deal with while loops where Condition_Actions is set
-   --  5. Deal with loops with iterators over arrays and containers
-   --  6. Insert polling call if required
+   --  5. Deal with loops over predicated subtypes
+   --  6. Deal with loops with iterators over arrays and containers
+   --  7. Insert polling call if required
 
    procedure Expand_N_Loop_Statement (N : Node_Id) is
       Loc  : constant Source_Ptr := Sloc (N);
@@ -2990,33 +2999,15 @@  package body Exp_Ch5 is
       --  Nothing more to do for plain loop with no iteration scheme
 
       if No (Isc) then
-         return;
-      end if;
+         null;
+
+      --  Case of for loop (Loop_Parameter_Specfication present)
 
       --  Note: we do not have to worry about validity checking of the for loop
       --  range bounds here, since they were frozen with constant declarations
       --  and it is during that process that the validity checking is done.
 
-      --  Handle the case where we have a for loop with the range type being an
-      --  enumeration type with non-standard representation. In this case we
-      --  expand:
-
-      --    for x in [reverse] a .. b loop
-      --       ...
-      --    end loop;
-
-      --  to
-
-      --    for xP in [reverse] integer
-      --                          range etype'Pos (a) .. etype'Pos (b) loop
-      --       declare
-      --          x : constant etype := Pos_To_Rep (xP);
-      --       begin
-      --          ...
-      --       end;
-      --    end loop;
-
-      if Present (Loop_Parameter_Specification (Isc)) then
+      elsif Present (Loop_Parameter_Specification (Isc)) then
          declare
             LPS     : constant Node_Id   := Loop_Parameter_Specification (Isc);
             Loop_Id : constant Entity_Id := Defining_Identifier (LPS);
@@ -3026,95 +3017,129 @@  package body Exp_Ch5 is
             New_Id  : Entity_Id;
 
          begin
-            if not Is_Enumeration_Type (Btype)
-              or else No (Enum_Pos_To_Rep (Btype))
+            --  Deal with loop over predicates
+
+            if Is_Discrete_Type (Ltype)
+              and then Present (Predicate_Function (Ltype))
             then
-               return;
-            end if;
+               Expand_Predicated_Loop (N);
 
-            New_Id :=
-              Make_Defining_Identifier (Loc,
-                Chars => New_External_Name (Chars (Loop_Id), 'P'));
+            --  Handle the case where we have a for loop with the range type
+            --  being an enumeration type with non-standard representation.
+            --  In this case we expand:
+
+            --    for x in [reverse] a .. b loop
+            --       ...
+            --    end loop;
+
+            --  to
+
+            --    for xP in [reverse] integer
+            --      range etype'Pos (a) .. etype'Pos (b)
+            --    loop
+            --       declare
+            --          x : constant etype := Pos_To_Rep (xP);
+            --       begin
+            --          ...
+            --       end;
+            --    end loop;
 
-            --  If the type has a contiguous representation, successive values
-            --  can be generated as offsets from the first literal.
+            elsif Is_Enumeration_Type (Btype)
+              and then Present (Enum_Pos_To_Rep (Btype))
+            then
+               New_Id :=
+                 Make_Defining_Identifier (Loc,
+                   Chars => New_External_Name (Chars (Loop_Id), 'P'));
 
-            if Has_Contiguous_Rep (Btype) then
-               Expr :=
-                  Unchecked_Convert_To (Btype,
-                    Make_Op_Add (Loc,
-                      Left_Opnd =>
-                         Make_Integer_Literal (Loc,
-                           Enumeration_Rep (First_Literal (Btype))),
-                      Right_Opnd => New_Reference_To (New_Id, Loc)));
-            else
-               --  Use the constructed array Enum_Pos_To_Rep
+               --  If the type has a contiguous representation, successive
+               --  values can be generated as offsets from the first literal.
 
-               Expr :=
-                 Make_Indexed_Component (Loc,
-                   Prefix => New_Reference_To (Enum_Pos_To_Rep (Btype), Loc),
-                   Expressions => New_List (New_Reference_To (New_Id, Loc)));
-            end if;
+               if Has_Contiguous_Rep (Btype) then
+                  Expr :=
+                     Unchecked_Convert_To (Btype,
+                       Make_Op_Add (Loc,
+                         Left_Opnd =>
+                            Make_Integer_Literal (Loc,
+                              Enumeration_Rep (First_Literal (Btype))),
+                         Right_Opnd => New_Reference_To (New_Id, Loc)));
+               else
+                  --  Use the constructed array Enum_Pos_To_Rep
 
-            Rewrite (N,
-              Make_Loop_Statement (Loc,
-                Identifier => Identifier (N),
+                  Expr :=
+                    Make_Indexed_Component (Loc,
+                      Prefix      =>
+                        New_Reference_To (Enum_Pos_To_Rep (Btype), Loc),
+                      Expressions =>
+                        New_List (New_Reference_To (New_Id, Loc)));
+               end if;
 
-                Iteration_Scheme =>
-                  Make_Iteration_Scheme (Loc,
-                    Loop_Parameter_Specification =>
-                      Make_Loop_Parameter_Specification (Loc,
-                        Defining_Identifier => New_Id,
-                        Reverse_Present => Reverse_Present (LPS),
+               Rewrite (N,
+                 Make_Loop_Statement (Loc,
+                   Identifier => Identifier (N),
 
-                        Discrete_Subtype_Definition =>
-                          Make_Subtype_Indication (Loc,
+                   Iteration_Scheme =>
+                     Make_Iteration_Scheme (Loc,
+                       Loop_Parameter_Specification =>
+                         Make_Loop_Parameter_Specification (Loc,
+                           Defining_Identifier => New_Id,
+                           Reverse_Present => Reverse_Present (LPS),
 
-                            Subtype_Mark =>
-                              New_Reference_To (Standard_Natural, Loc),
+                           Discrete_Subtype_Definition =>
+                             Make_Subtype_Indication (Loc,
 
-                            Constraint =>
-                              Make_Range_Constraint (Loc,
-                                Range_Expression =>
-                                  Make_Range (Loc,
-
-                                    Low_Bound =>
-                                      Make_Attribute_Reference (Loc,
-                                        Prefix =>
-                                          New_Reference_To (Btype, Loc),
-
-                                        Attribute_Name => Name_Pos,
-
-                                        Expressions => New_List (
-                                          Relocate_Node
-                                            (Type_Low_Bound (Ltype)))),
-
-                                    High_Bound =>
-                                      Make_Attribute_Reference (Loc,
-                                        Prefix =>
-                                          New_Reference_To (Btype, Loc),
-
-                                        Attribute_Name => Name_Pos,
-
-                                        Expressions => New_List (
-                                          Relocate_Node
-                                            (Type_High_Bound (Ltype))))))))),
-
-                Statements => New_List (
-                  Make_Block_Statement (Loc,
-                    Declarations => New_List (
-                      Make_Object_Declaration (Loc,
-                        Defining_Identifier => Loop_Id,
-                        Constant_Present    => True,
-                        Object_Definition   => New_Reference_To (Ltype, Loc),
-                        Expression          => Expr)),
+                               Subtype_Mark =>
+                                 New_Reference_To (Standard_Natural, Loc),
 
-                    Handled_Statement_Sequence =>
-                      Make_Handled_Sequence_Of_Statements (Loc,
-                        Statements => Statements (N)))),
+                               Constraint =>
+                                 Make_Range_Constraint (Loc,
+                                   Range_Expression =>
+                                     Make_Range (Loc,
+
+                                       Low_Bound =>
+                                         Make_Attribute_Reference (Loc,
+                                           Prefix =>
+                                             New_Reference_To (Btype, Loc),
+
+                                           Attribute_Name => Name_Pos,
+
+                                           Expressions => New_List (
+                                             Relocate_Node
+                                               (Type_Low_Bound (Ltype)))),
+
+                                       High_Bound =>
+                                         Make_Attribute_Reference (Loc,
+                                           Prefix =>
+                                             New_Reference_To (Btype, Loc),
+
+                                           Attribute_Name => Name_Pos,
+
+                                           Expressions => New_List (
+                                             Relocate_Node
+                                               (Type_High_Bound
+                                                  (Ltype))))))))),
+
+                   Statements => New_List (
+                     Make_Block_Statement (Loc,
+                       Declarations => New_List (
+                         Make_Object_Declaration (Loc,
+                           Defining_Identifier => Loop_Id,
+                           Constant_Present    => True,
+                           Object_Definition   =>
+                             New_Reference_To (Ltype, Loc),
+                           Expression          => Expr)),
+
+                       Handled_Statement_Sequence =>
+                         Make_Handled_Sequence_Of_Statements (Loc,
+                           Statements => Statements (N)))),
 
-                End_Label => End_Label (N)));
-            Analyze (N);
+                   End_Label => End_Label (N)));
+               Analyze (N);
+
+            --  Nothing to do with other cases of for loops
+
+            else
+               null;
+            end if;
          end;
 
       --  Second case, if we have a while loop with Condition_Actions set, then
@@ -3162,6 +3187,8 @@  package body Exp_Ch5 is
             Analyze (N);
          end;
 
+      --  Here to deal with iterator case
+
       elsif Present (Isc)
         and then Present (Iterator_Specification (Isc))
       then
@@ -3169,6 +3196,215 @@  package body Exp_Ch5 is
       end if;
    end Expand_N_Loop_Statement;
 
+   ----------------------------
+   -- Expand_Predicated_Loop --
+   ----------------------------
+
+   --  Note: the expander can handle generation of loops over predicated
+   --  subtypes for both the dynamic and static cases. Depending on what
+   --  we decide is allowed in Ada 2012 mode and/or extentions allowed
+   --  mode, the semantic analyzer may disallow one or both forms.
+
+   procedure Expand_Predicated_Loop (N : Node_Id) is
+      Loc     : constant Source_Ptr := Sloc (N);
+      Isc     : constant Node_Id    := Iteration_Scheme (N);
+      LPS     : constant Node_Id    := Loop_Parameter_Specification (Isc);
+      Loop_Id : constant Entity_Id  := Defining_Identifier (LPS);
+      Ltype   : constant Entity_Id  := Etype (Loop_Id);
+      Stat    : constant List_Id    := Static_Predicate (Ltype);
+      Stmts   : constant List_Id    := Statements (N);
+
+   begin
+      --  Case of iteration over non-static predicate. In this case we
+      --  generate the sequence:
+
+      --     for J in Ltype'First .. Ltype'Last loop
+      --        if Ltype_Predicate_Function (J) then
+      --           body;
+      --        end if;
+      --     end loop;
+
+      if No (Stat) then
+
+         --  The analyzer already expanded the First/Last, so all we have
+         --  to do is wrap the body within the predicate function test.
+
+         Set_Statements (N, New_List (
+           Make_If_Statement (Loc,
+             Condition =>
+               Make_Predicate_Call (Ltype, New_Occurrence_Of (Loop_Id, Loc)),
+             Then_Statements => Stmts)));
+         Analyze (First (Statements (N)));
+
+      --  For expansion over a static predicate we generate the following
+
+      --     declare
+      --        J : Ltype := min-val;
+      --     begin
+      --        loop
+      --           body
+      --           case J is
+      --              when endpoint => J := startpoint;
+      --              when endpoint => J := startpoint;
+      --              ...
+      --              when max-val  => exit;
+      --              when others   => J := Lval'Succ (J);
+      --           end case;
+      --        end loop;
+      --     end;
+
+      --  To make this a little clearer, let's take a specific example:
+
+      --        type Int is range 1 .. 10;
+      --        subtype L is Int with
+      --          predicate => L in 3 | 10 | 5 .. 7;
+      --          ...
+      --        for L in StaticP loop
+      --           Put_Line ("static:" & J'Img);
+      --        end loop;
+
+      --  In this case, the loop is transformed into
+
+      --     begin
+      --        J : L := 3;
+      --        loop
+      --           body
+      --           case J is
+      --              when 3  => J := 5;
+      --              when 7  => J := 10;
+      --              when 10 => exit;
+      --              when others  => J := L'Succ (J);
+      --           end case;
+      --        end loop;
+      --     end;
+
+      else
+         Static_Predicate : declare
+            S    : Node_Id;
+            D    : Node_Id;
+            P    : Node_Id;
+            Alts : List_Id;
+            Cstm : Node_Id;
+
+            function Lo_Val (N : Node_Id) return Node_Id;
+            --  Given static expression or static range, returns an identifier
+            --  whose value is the low bound of the expression value or range.
+
+            function Hi_Val (N : Node_Id) return Node_Id;
+            --  Given static expression or static range, returns an identifier
+            --  whose value is the high bound of the expression value or range.
+
+            ------------
+            -- Hi_Val --
+            ------------
+
+            function Hi_Val (N : Node_Id) return Node_Id is
+            begin
+               if Is_Static_Expression (N) then
+                  return New_Copy (N);
+               else
+                  pragma Assert (Nkind (N) = N_Range);
+                  return New_Copy (High_Bound (N));
+               end if;
+            end Hi_Val;
+
+            ------------
+            -- Lo_Val --
+            ------------
+
+            function Lo_Val (N : Node_Id) return Node_Id is
+            begin
+               if Is_Static_Expression (N) then
+                  return New_Copy (N);
+               else
+                  pragma Assert (Nkind (N) = N_Range);
+                  return New_Copy (Low_Bound (N));
+               end if;
+            end Lo_Val;
+
+         --  Start of processing for Static_Predicate
+
+         begin
+            --  Convert loop identifier to normal variable and reanalyze it so
+            --  that this conversion works. We have to use the same defining
+            --  identifier, since there may be references in the loop body.
+
+            Set_Analyzed (Loop_Id, False);
+            Set_Ekind    (Loop_Id, E_Variable);
+
+            --  Loop to create branches of case statement
+
+            Alts := New_List;
+            P := First (Stat);
+            while Present (P) loop
+               if No (Next (P)) then
+                  S := Make_Exit_Statement (Loc);
+               else
+                  S :=
+                    Make_Assignment_Statement (Loc,
+                      Name       => New_Occurrence_Of (Loop_Id, Loc),
+                      Expression => Lo_Val (Next (P)));
+                  Set_Suppress_Assignment_Checks (S);
+               end if;
+
+               Append_To (Alts,
+                 Make_Case_Statement_Alternative (Loc,
+                   Statements       => New_List (S),
+                   Discrete_Choices => New_List (Hi_Val (P))));
+
+               Next (P);
+            end loop;
+
+            --  Add others choice
+
+            S :=
+               Make_Assignment_Statement (Loc,
+                 Name       => New_Occurrence_Of (Loop_Id, Loc),
+                 Expression =>
+                   Make_Attribute_Reference (Loc,
+                     Prefix => New_Occurrence_Of (Ltype, Loc),
+                     Attribute_Name => Name_Succ,
+                     Expressions    => New_List (
+                       New_Occurrence_Of (Loop_Id, Loc))));
+            Set_Suppress_Assignment_Checks (S);
+
+            Append_To (Alts,
+              Make_Case_Statement_Alternative (Loc,
+                Discrete_Choices => New_List (Make_Others_Choice (Loc)),
+                Statements       => New_List (S)));
+
+            --  Construct case statement and append to body statements
+
+            Cstm :=
+              Make_Case_Statement (Loc,
+                Expression   => New_Occurrence_Of (Loop_Id, Loc),
+                Alternatives => Alts);
+            Append_To (Stmts, Cstm);
+
+            --  Rewrite the loop
+
+            D :=
+               Make_Object_Declaration (Loc,
+                 Defining_Identifier => Loop_Id,
+                 Object_Definition   => New_Occurrence_Of (Ltype, Loc),
+                 Expression          => Lo_Val (First (Stat)));
+            Set_Suppress_Assignment_Checks (D);
+
+            Rewrite (N,
+              Make_Block_Statement (Loc,
+                Declarations               => New_List (D),
+                Handled_Statement_Sequence =>
+                  Make_Handled_Sequence_Of_Statements (Loc,
+                    Statements => New_List (
+                      Make_Loop_Statement (Loc,
+                        Statements => Stmts,
+                        End_Label  => Empty)))));
+
+            Analyze (N);
+         end Static_Predicate;
+      end if;
+   end Expand_Predicated_Loop;
+
    ------------------------------
    -- Make_Tag_Ctrl_Assignment --
    ------------------------------
Index: sem_ch5.adb
===================================================================
--- sem_ch5.adb	(revision 165829)
+++ sem_ch5.adb	(working copy)
@@ -1832,18 +1832,34 @@  package body Sem_Ch5 is
                   return;
                end if;
 
-               --  The subtype indication may denote the completion of an
-               --  incomplete type declaration.
+               --  Some additional checks if we are iterating through a type
 
                if Is_Entity_Name (DS)
                  and then Present (Entity (DS))
                  and then Is_Type (Entity (DS))
-                 and then Ekind (Entity (DS)) = E_Incomplete_Type
                then
-                  Set_Entity (DS, Get_Full_View (Entity (DS)));
-                  Set_Etype  (DS, Entity (DS));
+                  --  The subtype indication may denote the completion of an
+                  --  incomplete type declaration.
+
+                  if Ekind (Entity (DS)) = E_Incomplete_Type then
+                     Set_Entity (DS, Get_Full_View (Entity (DS)));
+                     Set_Etype  (DS, Entity (DS));
+                  end if;
+
+                  --  Attempt to iterate through non-static predicate
+
+                  if Is_Discrete_Type (Entity (DS))
+                    and then Present (Predicate_Function (Entity (DS)))
+                    and then No (Static_Predicate (Entity (DS)))
+                  then
+                     Bad_Predicated_Subtype_Use
+                       ("cannot use subtype& with non-static "
+                        & "predicate for loop iteration", DS, Entity (DS));
+                  end if;
                end if;
 
+               --  Error if not discrete type
+
                if not Is_Discrete_Type (Etype (DS)) then
                   Wrong_Type (DS, Any_Discrete);
                   Set_Etype (DS, Any_Type);
Index: exp_attr.adb
===================================================================
--- exp_attr.adb	(revision 165819)
+++ exp_attr.adb	(working copy)
@@ -5407,9 +5407,13 @@  package body Exp_Attr is
 
    --  These checks are not generated for modular types, since the proper
    --  semantics for Succ and Pred on modular types is to wrap, not raise CE.
+   --  We also suppress these checks if we are the right side of an assignment
+   --  statement or the expression of an object declaration, where the flag
+   --  Suppress_Assignment_Checks is set for the assignment/declaration.
 
    procedure Expand_Pred_Succ (N : Node_Id) is
       Loc  : constant Source_Ptr := Sloc (N);
+      P    : constant Node_Id    := Parent (N);
       Cnam : Name_Id;
 
    begin
@@ -5419,18 +5423,22 @@  package body Exp_Attr is
          Cnam := Name_Last;
       end if;
 
-      Insert_Action (N,
-        Make_Raise_Constraint_Error (Loc,
-          Condition =>
-            Make_Op_Eq (Loc,
-              Left_Opnd =>
-                Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
-              Right_Opnd =>
-                Make_Attribute_Reference (Loc,
-                  Prefix =>
-                    New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
-                  Attribute_Name => Cnam)),
-          Reason => CE_Overflow_Check_Failed));
+      if not Nkind_In (P, N_Assignment_Statement, N_Object_Declaration)
+        or else not Suppress_Assignment_Checks (P)
+      then
+         Insert_Action (N,
+           Make_Raise_Constraint_Error (Loc,
+             Condition =>
+               Make_Op_Eq (Loc,
+                 Left_Opnd =>
+                   Duplicate_Subexpr_Move_Checks (First (Expressions (N))),
+                 Right_Opnd =>
+                   Make_Attribute_Reference (Loc,
+                     Prefix =>
+                       New_Reference_To (Base_Type (Etype (Prefix (N))), Loc),
+                     Attribute_Name => Cnam)),
+             Reason => CE_Overflow_Check_Failed));
+      end if;
    end Expand_Pred_Succ;
 
    -------------------
Index: sinfo.adb
===================================================================
--- sinfo.adb	(revision 165811)
+++ sinfo.adb	(working copy)
@@ -2851,6 +2851,15 @@  package body Sinfo is
       return Node5 (N);
    end Subtype_Indication;
 
+   function Suppress_Assignment_Checks
+      (N : Node_Id) return Boolean is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement
+        or else NT (N).Nkind = N_Object_Declaration);
+      return Flag18 (N);
+   end Suppress_Assignment_Checks;
+
    function Suppress_Loop_Warnings
       (N : Node_Id) return Boolean is
    begin
@@ -5886,6 +5895,15 @@  package body Sinfo is
       Set_List2_With_Parent (N, Val);
    end Set_Subtype_Marks;
 
+   procedure Set_Suppress_Assignment_Checks
+      (N : Node_Id; Val : Boolean := True) is
+   begin
+      pragma Assert (False
+        or else NT (N).Nkind = N_Assignment_Statement
+        or else NT (N).Nkind = N_Object_Declaration);
+      Set_Flag18 (N, Val);
+   end Set_Suppress_Assignment_Checks;
+
    procedure Set_Suppress_Loop_Warnings
       (N : Node_Id; Val : Boolean := True) is
    begin
Index: sinfo.ads
===================================================================
--- sinfo.ads	(revision 165826)
+++ sinfo.ads	(working copy)
@@ -1733,6 +1733,13 @@  package Sinfo is
    --    value of a type whose size is not known at compile time on the
    --    secondary stack.
 
+   --  Suppress_Assignment_Checks (Flag18-Sem)
+   --    Used in genererated N_Assignment_Statement nodes to suppress predicate
+   --    and range checks in cases where the generated code knows that the
+   --    value being assigned is in range and satisifies any predicate. Also
+   --    can be set in N_Object_Declaration nodes, to similarly suppress any
+   --    checks on the initializing value.
+
    --  Suppress_Loop_Warnings (Flag17-Sem)
    --    Used in N_Loop_Statement node to indicate that warnings within the
    --    body of the loop should be suppressed. This is set when the range
@@ -2331,6 +2338,7 @@  package Sinfo is
       --  Exception_Junk (Flag8-Sem)
       --  Is_Subprogram_Descriptor (Flag16-Sem)
       --  Has_Init_Expression (Flag14)
+      --  Suppress_Assignment_Checks (Flag18-Sem)
 
       -------------------------------------
       -- 3.3.1  Defining Identifier List --
@@ -4052,9 +4060,10 @@  package Sinfo is
       --  Backwards_OK (Flag6-Sem)
       --  No_Ctrl_Actions (Flag7-Sem)
       --  Componentwise_Assignment (Flag14-Sem)
+      --  Suppress_Assignment_Checks (Flag18-Sem)
 
       --  Note: if a range check is required, then the Do_Range_Check flag
-      --  is set in the Expression (right hand side), with the check being
+      --  is set in the Expression (right hand side), with the check b6ing
       --  done against the type of the Name (left hand side).
 
       --  Note: the back end places some restrictions on the form of the
@@ -8844,6 +8853,9 @@  package Sinfo is
    function Subtype_Marks
      (N : Node_Id) return List_Id;    -- List2
 
+   function Suppress_Assignment_Checks
+     (N : Node_Id) return Boolean;    -- Flag18
+
    function Suppress_Loop_Warnings
      (N : Node_Id) return Boolean;    -- Flag17
 
@@ -9804,6 +9816,9 @@  package Sinfo is
    procedure Set_Subtype_Marks
      (N : Node_Id; Val : List_Id);            -- List2
 
+   procedure Set_Suppress_Assignment_Checks
+     (N : Node_Id; Val : Boolean := True);    -- Flag18
+
    procedure Set_Suppress_Loop_Warnings
      (N : Node_Id; Val : Boolean := True);    -- Flag17
 
@@ -11899,6 +11914,7 @@  package Sinfo is
    pragma Inline (Subtype_Indication);
    pragma Inline (Subtype_Mark);
    pragma Inline (Subtype_Marks);
+   pragma Inline (Suppress_Assignment_Checks);
    pragma Inline (Suppress_Loop_Warnings);
    pragma Inline (Synchronized_Present);
    pragma Inline (Tagged_Present);
@@ -12215,6 +12231,7 @@  package Sinfo is
    pragma Inline (Set_Subtype_Indication);
    pragma Inline (Set_Subtype_Mark);
    pragma Inline (Set_Subtype_Marks);
+   pragma Inline (Set_Suppress_Assignment_Checks);
    pragma Inline (Set_Suppress_Loop_Warnings);
    pragma Inline (Set_Synchronized_Present);
    pragma Inline (Set_Tagged_Present);
Index: checks.adb
===================================================================
--- checks.adb	(revision 165808)
+++ checks.adb	(working copy)
@@ -3749,6 +3749,15 @@  package body Checks is
          return;
       end if;
 
+      --  Do not set range check flag if parent is assignment statement or
+      --  object declaration with Suppress_Assignment_Checks flag set
+
+      if Nkind_In (Parent (N), N_Assignment_Statement, N_Object_Declaration)
+        and then Suppress_Assignment_Checks (Parent (N))
+      then
+         return;
+      end if;
+
       --  Check for various cases where we should suppress the range check
 
       --  No check if range checks suppressed for type of node
Index: sem_case.adb
===================================================================
--- sem_case.adb	(revision 165829)
+++ sem_case.adb	(working copy)
@@ -866,8 +866,8 @@  package body Sem_Case is
                              or else No (Static_Predicate (E))
                            then
                               Bad_Predicated_Subtype_Use
-                                ("cannot use subtype&  with non-static "
-                                 & "predicate as case alternative", N, E);
+                                ("cannot use subtype& with non-static "
+                                 & "predicate as case alternative", Choice, E);
 
                               --  Static predicate case
 
Index: exp_ch4.adb
===================================================================
--- exp_ch4.adb	(revision 165813)
+++ exp_ch4.adb	(working copy)
@@ -4398,23 +4398,17 @@  package body Exp_Ch4 is
 
       procedure Substitute_Valid_Check is
       begin
-         --  Don't do this for type with predicates, since we don't care in
-         --  this case if it gets optimized away, the critical test is the
-         --  call to the predicate function
-
-         if not Has_Predicates (Ltyp) then
-            Rewrite (N,
-              Make_Attribute_Reference (Loc,
-                Prefix         => Relocate_Node (Lop),
-                Attribute_Name => Name_Valid));
-
-            Analyze_And_Resolve (N, Restyp);
-
-            Error_Msg_N ("?explicit membership test may be optimized away", N);
-            Error_Msg_N -- CODEFIX
-              ("\?use ''Valid attribute instead", N);
-            return;
-         end if;
+         Rewrite (N,
+           Make_Attribute_Reference (Loc,
+             Prefix         => Relocate_Node (Lop),
+             Attribute_Name => Name_Valid));
+
+         Analyze_And_Resolve (N, Restyp);
+
+         Error_Msg_N ("?explicit membership test may be optimized away", N);
+         Error_Msg_N -- CODEFIX
+           ("\?use ''Valid attribute instead", N);
+         return;
       end Substitute_Valid_Check;
 
    --  Start of processing for Expand_N_In
@@ -4437,7 +4431,9 @@  package body Exp_Ch4 is
       --  subtype. This is suspicious usage and we replace it with a 'Valid
       --  test and give a warning. For floating point types however, this is a
       --  standard way to check for finite numbers, and using 'Valid would
-      --  typically be a pessimization.
+      --  typically be a pessimization. Also skip this test for predicated
+      --  types, since it is perfectly reasonable to check if a value meets
+      --  its predicate.
 
       if Is_Scalar_Type (Ltyp)
         and then not Is_Floating_Point_Type (Ltyp)
@@ -4445,7 +4441,8 @@  package body Exp_Ch4 is
         and then Ltyp = Entity (Rop)
         and then Comes_From_Source (N)
         and then VM_Target = No_VM
-        and then No (Predicate_Function (Rtyp))
+        and then not (Is_Discrete_Type (Ltyp)
+                       and then Present (Predicate_Function (Ltyp)))
       then
          Substitute_Valid_Check;
          return;
@@ -4688,22 +4685,25 @@  package body Exp_Ch4 is
             --  type if they come from the original type definition. Also this
             --  way we get all the processing above for an explicit range.
 
-            --  Don't do this for a type with predicates, since we would lose
-            --  the predicate from this rewriting (test goes to base type).
+               --  Don't do this for predicated types, since in this case we
+               --  want to check the predicate!
+
+            elsif Is_Scalar_Type (Typ) then
+               if No (Predicate_Function (Typ)) then
+                  Rewrite (Rop,
+                    Make_Range (Loc,
+                      Low_Bound =>
+                        Make_Attribute_Reference (Loc,
+                          Attribute_Name => Name_First,
+                          Prefix => New_Reference_To (Typ, Loc)),
+
+                      High_Bound =>
+                        Make_Attribute_Reference (Loc,
+                          Attribute_Name => Name_Last,
+                          Prefix => New_Reference_To (Typ, Loc))));
+                  Analyze_And_Resolve (N, Restyp);
+               end if;
 
-            elsif Is_Scalar_Type (Typ) and then not Has_Predicates (Typ) then
-               Rewrite (Rop,
-                 Make_Range (Loc,
-                   Low_Bound =>
-                     Make_Attribute_Reference (Loc,
-                       Attribute_Name => Name_First,
-                       Prefix => New_Reference_To (Typ, Loc)),
-
-                   High_Bound =>
-                     Make_Attribute_Reference (Loc,
-                       Attribute_Name => Name_Last,
-                       Prefix => New_Reference_To (Typ, Loc))));
-               Analyze_And_Resolve (N, Restyp);
                goto Leave;
 
             --  Ada 2005 (AI-216): Program_Error is raised when evaluating
@@ -4843,24 +4843,33 @@  package body Exp_Ch4 is
 
    <<Leave>>
 
-      --  If a predicate is present, then we do the predicate test
+      --  If a predicate is present, then we do the predicate test, but we
+      --  most certainly want to omit this if we are within the predicate
+      --  function itself, since otherwise we have an infinite recursion!
 
-      if Present (Predicate_Function (Rtyp)) then
-         Rewrite (N,
-           Make_And_Then (Loc,
-             Left_Opnd  => Relocate_Node (N),
-             Right_Opnd => Make_Predicate_Call (Rtyp, Lop)));
+      declare
+         PFunc : constant Entity_Id := Predicate_Function (Rtyp);
 
-         --  Analyze new expression, mark left operand as analyzed to
-         --  avoid infinite recursion adding predicate calls.
+      begin
+         if Present (PFunc)
+           and then Current_Scope /= PFunc
+         then
+            Rewrite (N,
+              Make_And_Then (Loc,
+                Left_Opnd  => Relocate_Node (N),
+                Right_Opnd => Make_Predicate_Call (Rtyp, Lop)));
 
-         Set_Analyzed (Left_Opnd (N));
-         Analyze_And_Resolve (N, Standard_Boolean);
+            --  Analyze new expression, mark left operand as analyzed to
+            --  avoid infinite recursion adding predicate calls.
 
-         --  All done, skip attempt at compile time determination of result
+            Set_Analyzed (Left_Opnd (N));
+            Analyze_And_Resolve (N, Standard_Boolean);
 
-         return;
-      end if;
+            --  All done, skip attempt at compile time determination of result
+
+            return;
+         end if;
+      end;
    end Expand_N_In;
 
    --------------------------------
Index: sem_ch13.adb
===================================================================
--- sem_ch13.adb	(revision 165829)
+++ sem_ch13.adb	(working copy)
@@ -3890,10 +3890,12 @@  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.
+            --  unwelcome noise in that case in instantiations. We also
+            --  generally suppress the message in instantiations.
 
             if Opt.List_Inherited_Aspects
               and then not Is_Generic_Actual_Type (Typ)
+              and then Instantiation_Depth (Sloc (Typ)) = 0
             then
                Error_Msg_Sloc := Sloc (Predicate_Function (T));
                Error_Msg_Node_2 := T;
@@ -4317,6 +4319,43 @@  package body Sem_Ch13 is
          --  now we can store the result as the predicate list.
 
          Set_Static_Predicate (Typ, Plist);
+
+         --  The processing for static predicates coalesced ranges and also
+         --  eliminated duplicates. We might as well replace the alternatives
+         --  list of the right operand of the membership test with the static
+         --  predicate list, which will be more efficient.
+
+         declare
+            New_Alts : constant List_Id := New_List;
+            Old_Node : Node_Id;
+            New_Node : Node_Id;
+
+         begin
+            Old_Node := First (Plist);
+            while Present (Old_Node) loop
+               New_Node := New_Copy (Old_Node);
+
+               if Nkind (New_Node) = N_Range then
+                  Set_Low_Bound  (New_Node, New_Copy (Low_Bound  (Old_Node)));
+                  Set_High_Bound (New_Node, New_Copy (High_Bound (Old_Node)));
+               end if;
+
+               Append_To (New_Alts, New_Node);
+               Next (Old_Node);
+            end loop;
+
+            --  Now update the membership test node
+
+            pragma Assert (Nkind (Expr) = N_In);
+
+            if List_Length (New_Alts) = 1 then
+               Set_Right_Opnd   (Expr, First (New_Alts));
+               Set_Alternatives (Expr, No_List);
+            else
+               Set_Alternatives (Expr, New_Alts);
+               Set_Right_Opnd   (Expr, Empty);
+            end if;
+         end;
       end Build_Static_Predicate;
 
    --  Start of processing for Build_Predicate_Function
Index: exp_ch3.adb
===================================================================
--- exp_ch3.adb	(revision 165815)
+++ exp_ch3.adb	(working copy)
@@ -4516,7 +4516,8 @@  package body Exp_Ch3 is
       --  there is an initializing expression, or for default initialization
       --  when we have at least one case of an explicit default initial value.
 
-      if Present (Predicate_Function (Typ))
+      if not Suppress_Assignment_Checks (N)
+        and then Present (Predicate_Function (Typ))
         and then
           (Present (Expr)
             or else
@@ -5029,7 +5030,11 @@  package body Exp_Ch3 is
 
                   if Do_Range_Check (Expr) then
                      Set_Do_Range_Check (Expr, False);
-                     Generate_Range_Check (Expr, Typ, CE_Range_Check_Failed);
+
+                     if not Suppress_Assignment_Checks (N) then
+                        Generate_Range_Check
+                          (Expr, Typ, CE_Range_Check_Failed);
+                     end if;
                   end if;
                end if;
             end if;