===================================================================
@@ -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 |
===================================================================
@@ -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
===================================================================
@@ -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,
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.