Patchwork [Ada] Implement Ada 2012 attributes First_Valid and Last_Valid

login
register
mail settings
Submitter Arnaud Charlet
Date March 15, 2012, 8:39 a.m.
Message ID <20120315083925.GA11890@adacore.com>
Download mbox | patch
Permalink /patch/146850/
State New
Headers show

Comments

Arnaud Charlet - March 15, 2012, 8:39 a.m.
This patch implements the new attributes First_Valid and Last_Valid.
These apply to static discrete types with at least one valid value.
The static discrete type may have a static predicate (which is the
case where these attributes are useful). They return the lowest and
highest values for which valid values (that is values that satisfy
any static predicate) exist.

The following shows error detection in action (compiled with
-gnat12 -gnatj60 -gnatld7)

     1. procedure FLValidError (P : Integer) is
     2.    subtype R1 is integer range 1 .. 0;
     3.    subtype R2 is integer range 1 .. 10
     4.      with Dynamic_Predicate => R2 > P;
     5.    subtype R3 is integer range 1 .. 10
     6.      with Static_Predicate => R3 > 12;
     7.    subtype R4 is integer range 1 .. P;
     8.
     9.    Val : Integer;
    10.
    11. begin
    12.    Val := Float'First_Valid;   -- Not discrete
                  |
        >>> prefix of "First_Valid" attribute must be
            discrete type

    13.    Val := Float'Last_Valid;    -- Not discrete
                  |
        >>> prefix of "Last_Valid" attribute must be
            discrete type

    14.    Val := R1'First_Valid;      -- No values
                  |
        >>> prefix of "First_Valid" attribute must be
            subtype with at least one value

    15.    Val := R1'Last_Valid;       -- No values
                  |
        >>> prefix of "Last_Valid" attribute must be
            subtype with at least one value

    16.    Val := R2'First_Valid;      -- Dynamic predicate
                  |
        >>> prefix of "First_Valid" attribute may not have
            dynamic predicate

    17.    Val := R2'Last_Valid;       -- Dynamic_Predicate
                  |
        >>> prefix of "Last_Valid" attribute may not have
            dynamic predicate

    18.    Val := R3'First_Valid;      -- No values
                  |
        >>> prefix of "First_Valid" attribute must be
            subtype with at least one value

    19.    Val := R3'Last_Valid;       -- No values
                  |
        >>> prefix of "Last_Valid" attribute must be
            subtype with at least one value

    20.    Val := R4'First_Valid;      -- Non-static subtype
                  |
        >>> prefix of "First_Valid" attribute must be a
            static subtype

    21.    Val := R4'Last_Valid;       -- Non-static subtype
                  |
        >>> prefix of "Last_Valid" attribute must be a
            static subtype

    22. end FLValidError;

The following compiles and executes quietly

     1. procedure FLRange is
     2.    subtype R1 is Integer range 1 .. 10;
     3.    subtype R2 is Integer range 1 .. 10
     4.      with Static_Predicate => R2 < 2 or R2 > 9;
     5.    subtype R3 is Integer range 1 .. 10
     6.      with Static_Predicate => R3 < 3 or R3 > 8;
     7.    subtype R4 is Integer range 1 .. 10
     8.      with Static_Predicate => R4 >= 3 and R4 <= 9;
     9.
    10.    procedure Fail is
    11.    begin
    12.       raise Program_Error;
    13.    end Fail;
    14.
    15. begin
    16.    if R1'First_Valid /= 1 or else R1'Last_Valid /= 10 then
    17.       Fail;
    18.    end if;
    19.
    20.    if R2'First_Valid /= 1 or else R2'Last_Valid /= 10 then
    21.       Fail;
    22.    end if;
    23.
    24.    if R3'First_Valid /= 1 or else R3'Last_Valid /= 10 then
    25.       Fail;
    26.    end if;
    27.
    28.    if R4'First_Valid /= 3 or else R4'Last_Valid /= 9 then
    29.       Fail;
    30.    end if;
    31. end FLRange;

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

2012-03-15  Robert Dewar  <dewar@adacore.com>

	* exp_attr.adb (Expand_N_Attribute_Reference): Add handling
	of First_Valid/Last_Valid.
	* sem_attr.adb (Check_First_Last_Valid): New procedure
	(Analyze_Attribute): Add handling of First_Valid and Last_Valid
	(Eval_Attribute): ditto.
	* snames.ads-tmpl: Add entries for First_Valid and Last_Valid.

Patch

Index: exp_attr.adb
===================================================================
--- exp_attr.adb	(revision 185390)
+++ exp_attr.adb	(working copy)
@@ -5701,10 +5701,12 @@ 
            Attribute_Enabled                      |
            Attribute_Epsilon                      |
            Attribute_Fast_Math                    |
+           Attribute_First_Valid                  |
            Attribute_Has_Access_Values            |
            Attribute_Has_Discriminants            |
            Attribute_Has_Tagged_Values            |
            Attribute_Large                        |
+           Attribute_Last_Valid                   |
            Attribute_Machine_Emax                 |
            Attribute_Machine_Emin                 |
            Attribute_Machine_Mantissa             |
Index: sem_attr.adb
===================================================================
--- sem_attr.adb	(revision 185390)
+++ sem_attr.adb	(working copy)
@@ -217,10 +217,14 @@ 
       --  allowed with a type that has predicates. If the type is a generic
       --  actual, then the message is a warning, and we generate code to raise
       --  program error with an appropriate reason. No error message is given
-      --  for internally generated uses of the attributes.
-      --  The legality rule only applies to scalar types, even though the
-      --  current AI mentions all subtypes.
+      --  for internally generated uses of the attributes. This legality rule
+      --  only applies to scalar types.
 
+      procedure Check_Ada_2012_Attribute;
+      --  Check that we are in Ada 2012 mode for an Ada 2012 attribute, and
+      --  issue appropriate messages if not (and return to caller even in
+      --  the error case).
+
       procedure Check_Array_Or_Scalar_Type;
       --  Common procedure used by First, Last, Range attribute to check
       --  that the prefix is a constrained array or scalar type, or a name
@@ -270,6 +274,9 @@ 
       --  reference when analyzing an inlined body will lose a proper warning
       --  on a useless with_clause.
 
+      procedure Check_First_Last_Valid;
+      --  Perform all checks for First_Valid and Last_Valid attributes
+
       procedure Check_Fixed_Point_Type;
       --  Verify that prefix of attribute N is a fixed type
 
@@ -862,6 +869,21 @@ 
          end if;
       end Bad_Attribute_For_Predicate;
 
+      ------------------------------
+      -- Check_Ada_2012_Attribute --
+      ------------------------------
+
+      procedure Check_Ada_2012_Attribute is
+      begin
+         if Ada_Version < Ada_2012 then
+            Error_Msg_Name_1 := Aname;
+            Error_Msg_N
+              ("attribute % is an Ada 2012 feature", N);
+            Error_Msg_N
+              ("\unit must be compiled with -gnat2012 switch", N);
+         end if;
+      end Check_Ada_2012_Attribute;
+
       --------------------------------
       -- Check_Array_Or_Scalar_Type --
       --------------------------------
@@ -1245,6 +1267,37 @@ 
       end Check_Enum_Image;
 
       ----------------------------
+      -- Check_First_Last_Valid --
+      ----------------------------
+
+      procedure Check_First_Last_Valid is
+      begin
+         Check_Ada_2012_Attribute;
+         Check_Discrete_Type;
+
+         if not Is_Static_Subtype (P_Type) then
+            Error_Attr_P ("prefix of % attribute must be a static subtype");
+         end if;
+
+         if Has_Predicates (P_Type)
+           and then No (Static_Predicate (P_Type))
+         then
+            Error_Attr_P
+              ("prefix of % attribute may not have dynamic predicate");
+         end if;
+
+         if Expr_Value (Type_Low_Bound (P_Type)) >
+            Expr_Value (Type_High_Bound (P_Type))
+           or else (Has_Predicates (P_Type)
+                     and then Is_Empty_List (Static_Predicate (P_Type)))
+         then
+            Error_Attr_P
+              ("prefix of % attribute must be subtype with "
+               & "at least one value");
+         end if;
+      end Check_First_Last_Valid;
+
+      ----------------------------
       -- Check_Fixed_Point_Type --
       ----------------------------
 
@@ -3241,6 +3294,14 @@ 
          Set_Etype (N, Universal_Integer);
 
       -----------------
+      -- First_Valid --
+      -----------------
+
+      when Attribute_First_Valid =>
+         Check_First_Last_Valid;
+         Set_Etype (N, P_Type);
+
+      -----------------
       -- Fixed_Value --
       -----------------
 
@@ -3456,6 +3517,14 @@ 
          Check_Component;
          Set_Etype (N, Universal_Integer);
 
+      ----------------
+      -- Last_Valid --
+      ----------------
+
+      when Attribute_Last_Valid =>
+         Check_First_Last_Valid;
+         Set_Etype (N, P_Type);
+
       ------------------
       -- Leading_Part --
       ------------------
@@ -3928,12 +3997,7 @@ 
       ----------------------
 
       when Attribute_Overlaps_Storage =>
-         if Ada_Version < Ada_2012 then
-            Error_Msg_N
-              ("attribute Overlaps_Storage is an Ada 2012 feature", N);
-            Error_Msg_N
-              ("\unit must be compiled with -gnat2012 switch", N);
-         end if;
+         Check_Ada_2012_Attribute;
          Check_E1;
 
          --  Both arguments must be objects of any type
@@ -4425,13 +4489,7 @@ 
       ------------------
 
       when Attribute_Same_Storage =>
-         if Ada_Version < Ada_2012 then
-            Error_Msg_N
-              ("attribute Same_Storage is an Ada 2012 feature", N);
-            Error_Msg_N
-              ("\unit must be compiled with -gnat2012 switch", N);
-         end if;
-
+         Check_Ada_2012_Attribute;
          Check_E1;
 
          --  The arguments must be objects of any type
@@ -5388,10 +5446,11 @@ 
       --  Used for First, Last and Length attributes applied to an array or
       --  array subtype. Sets the variables Lo_Bound and Hi_Bound to the low
       --  and high bound expressions for the index referenced by the attribute
-      --  designator (i.e. the first index if no expression is present, and
-      --  the N'th index if the value N is present as an expression). Also
-      --  used for First and Last of scalar types. Static is reset to False
-      --  if the type or index type is not statically constrained.
+      --  designator (i.e. the first index if no expression is present, and the
+      --  N'th index if the value N is present as an expression). Also used for
+      --  First and Last of scalar types and for First_Valid and Last_Valid.
+      --  Static is reset to False if the type or index type is not statically
+      --  constrained.
 
       function Statically_Denotes_Entity (N : Node_Id) return Boolean;
       --  Verify that the prefix of a potentially static array attribute
@@ -6460,6 +6519,31 @@ 
       end First_Attr;
 
       -----------------
+      -- First_Valid --
+      -----------------
+
+      when Attribute_First_Valid => First_Valid :
+      begin
+         if Has_Predicates (P_Type)
+           and then Present (Static_Predicate (P_Type))
+         then
+            declare
+               FirstN : constant Node_Id := First (Static_Predicate (P_Type));
+            begin
+               if Nkind (FirstN) = N_Range then
+                  Fold_Uint (N, Expr_Value (Low_Bound (FirstN)), Static);
+               else
+                  Fold_Uint (N, Expr_Value (FirstN), Static);
+               end if;
+            end;
+
+         else
+            Set_Bounds;
+            Fold_Uint (N, Expr_Value (Lo_Bound), Static);
+         end if;
+      end First_Valid;
+
+      -----------------
       -- Fixed_Value --
       -----------------
 
@@ -6634,7 +6718,7 @@ 
       -- Last --
       ----------
 
-      when Attribute_Last => Last :
+      when Attribute_Last => Last_Attr :
       begin
          Set_Bounds;
 
@@ -6658,8 +6742,33 @@ 
          else
             Check_Concurrent_Discriminant (Hi_Bound);
          end if;
-      end Last;
+      end Last_Attr;
 
+      ----------------
+      -- Last_Valid --
+      ----------------
+
+      when Attribute_Last_Valid => Last_Valid :
+      begin
+         if Has_Predicates (P_Type)
+           and then Present (Static_Predicate (P_Type))
+         then
+            declare
+               LastN : constant Node_Id := Last (Static_Predicate (P_Type));
+            begin
+               if Nkind (LastN) = N_Range then
+                  Fold_Uint (N, Expr_Value (High_Bound (LastN)), Static);
+               else
+                  Fold_Uint (N, Expr_Value (LastN), Static);
+               end if;
+            end;
+
+         else
+            Set_Bounds;
+            Fold_Uint (N, Expr_Value (Hi_Bound), Static);
+         end if;
+      end Last_Valid;
+
       ------------------
       -- Leading_Part --
       ------------------
@@ -8568,14 +8677,13 @@ 
                if Ada_Version >= Ada_2005
                  and then (Is_Local_Anonymous_Access (Btyp)
 
-                            --  Handle cases where Btyp is the
-                            --  anonymous access type of an Ada 2012
-                            --  stand-alone object.
+                            --  Handle cases where Btyp is the anonymous access
+                            --  type of an Ada 2012 stand-alone object.
 
                             or else Nkind (Associated_Node_For_Itype (Btyp)) =
                                                         N_Object_Declaration)
-                 and then Object_Access_Level (P)
-                          > Deepest_Type_Access_Level (Btyp)
+                 and then
+                   Object_Access_Level (P) > Deepest_Type_Access_Level (Btyp)
                  and then Attr_Id = Attribute_Access
                then
                   --  In an instance, this is a runtime check, but one we
Index: snames.ads-tmpl
===================================================================
--- snames.ads-tmpl	(revision 185390)
+++ snames.ads-tmpl	(working copy)
@@ -770,6 +770,7 @@ 
    Name_Fast_Math                      : constant Name_Id := N + $; -- GNAT
    Name_First                          : constant Name_Id := N + $;
    Name_First_Bit                      : constant Name_Id := N + $;
+   Name_First_Valid                    : constant Name_Id := N + $; -- Ada 12
    Name_Fixed_Value                    : constant Name_Id := N + $; -- GNAT
    Name_Fore                           : constant Name_Id := N + $;
    Name_Has_Access_Values              : constant Name_Id := N + $; -- GNAT
@@ -784,6 +785,7 @@ 
    Name_Large                          : constant Name_Id := N + $; -- Ada 83
    Name_Last                           : constant Name_Id := N + $;
    Name_Last_Bit                       : constant Name_Id := N + $;
+   Name_Last_Valid                     : constant Name_Id := N + $; -- Ada 12
    Name_Leading_Part                   : constant Name_Id := N + $;
    Name_Length                         : constant Name_Id := N + $;
    Name_Machine_Emax                   : constant Name_Id := N + $;
@@ -1332,6 +1334,7 @@ 
       Attribute_Fast_Math,
       Attribute_First,
       Attribute_First_Bit,
+      Attribute_First_Valid,
       Attribute_Fixed_Value,
       Attribute_Fore,
       Attribute_Has_Access_Values,
@@ -1346,6 +1349,7 @@ 
       Attribute_Large,
       Attribute_Last,
       Attribute_Last_Bit,
+      Attribute_Last_Valid,
       Attribute_Leading_Part,
       Attribute_Length,
       Attribute_Machine_Emax,