[Ada] Loops through types with static predicates

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.

[Ada] Loops through types with static predicates

Commit Message

Patch