The compiler may report errors on enumeration types with non-standard
representation (i.e. at least one literal has a representation value
different from its 'Pos value) processing attribute 'Enum_Rep.
It may also generate wrong code for the evaluation of 'Enum_Rep raising
Constraint_Error at runtime.
Tested on x86_64-pc-linux-gnu, committed on trunk
2018-08-21 Javier Miranda <mira...@adacore.com>
gcc/ada/
* checks.ads (Determine_Range): Adding documentation.
* checks.adb (Determine_Range): Don't deal with enumerated types
with non-standard representation.
(Convert_And_Check_Range): For conversion of enumeration types
with non standard representation to an integer type perform a
direct conversion to the target integer type.
gcc/testsuite/
* gnat.dg/enum4.adb: New testcase.--- gcc/ada/checks.adb
+++ gcc/ada/checks.adb
@@ -4490,6 +4490,11 @@ package body Checks is
or else not Is_Discrete_Type (Typ)
+ -- Don't deal with enumerated types with non-standard representation
+
+ or else (Is_Enumeration_Type (Typ)
+ and then Present (Enum_Pos_To_Rep (Base_Type (Typ))))
+
-- Ignore type for which an error has been posted, since range in
-- this case may well be a bogosity deriving from the error. Also
-- ignore if error posted on the reference node.
@@ -6758,9 +6763,36 @@ package body Checks is
-----------------------------
procedure Convert_And_Check_Range is
- Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
+ Tnn : constant Entity_Id := Make_Temporary (Loc, 'T', N);
+ Conv_Node : Node_Id;
begin
+ -- For enumeration types with non-standard representation this is a
+ -- direct conversion from the enumeration type to the target integer
+ -- type, which is treated by the back end as a normal integer type
+ -- conversion, treating the enumeration type as an integer, which is
+ -- exactly what we want. We set Conversion_OK to make sure that the
+ -- analyzer does not complain about what otherwise might be an
+ -- illegal conversion.
+
+ if Is_Enumeration_Type (Source_Base_Type)
+ and then Present (Enum_Pos_To_Rep (Source_Base_Type))
+ and then Is_Integer_Type (Target_Base_Type)
+ then
+ Conv_Node :=
+ OK_Convert_To (
+ Typ => Target_Base_Type,
+ Expr => Duplicate_Subexpr (N));
+
+ -- Common case
+
+ else
+ Conv_Node :=
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
+ Expression => Duplicate_Subexpr (N));
+ end if;
+
-- We make a temporary to hold the value of the converted value
-- (converted to the base type), and then do the test against this
-- temporary. The conversion itself is replaced by an occurrence of
@@ -6776,10 +6808,7 @@ package body Checks is
Defining_Identifier => Tnn,
Object_Definition => New_Occurrence_Of (Target_Base_Type, Loc),
Constant_Present => True,
- Expression =>
- Make_Type_Conversion (Loc,
- Subtype_Mark => New_Occurrence_Of (Target_Base_Type, Loc),
- Expression => Duplicate_Subexpr (N))),
+ Expression => Conv_Node),
Make_Raise_Constraint_Error (Loc,
Condition =>
--- gcc/ada/checks.ads
+++ gcc/ada/checks.ads
@@ -310,14 +310,16 @@ package Checks is
-- then OK is True on return, and Lo and Hi are set to a conservative
-- estimate of the possible range of values of N. Thus if OK is True on
-- return, the value of the subexpression N is known to lie in the range
- -- Lo .. Hi (inclusive). If the expression is not of a discrete type, or
- -- some kind of error condition is detected, then OK is False on exit, and
- -- Lo/Hi are set to No_Uint. Thus the significance of OK being False on
- -- return is that no useful information is available on the range of the
- -- expression. Assume_Valid determines whether the processing is allowed to
- -- assume that values are in range of their subtypes. If it is set to True,
- -- then this assumption is valid, if False, then processing is done using
- -- base types to allow invalid values.
+ -- Lo .. Hi (inclusive). For enumeration and character literals the values
+ -- returned are the Pos value in the relevant enumeration type. If the
+ -- expression is not of a discrete type, or some kind of error condition
+ -- is detected, then OK is False on exit, and Lo/Hi are set to No_Uint.
+ -- Thus the significance of OK being False on return is that no useful
+ -- information is available on the range of the expression. Assume_Valid
+ -- determines whether the processing is allowed to assume that values are
+ -- in range of their subtypes. If it is set to True, then this assumption
+ -- is valid, if False, then processing is done using base types to allow
+ -- invalid values.
procedure Determine_Range_R
(N : Node_Id;
--- /dev/null
new file mode 100644
+++ gcc/testsuite/gnat.dg/enum4.adb
@@ -0,0 +1,59 @@
+-- { dg-do run }
+
+procedure Enum4 is
+
+ procedure Assert (Expected, Actual : String) is
+ begin
+ if Expected /= Actual then
+ raise Program_Error;
+ end if;
+ end Assert;
+
+ procedure Test_1 is
+ type Test_Enum is (Enum_1, Enum_2);
+ for Test_Enum use (Enum_1=> 8, Enum_2=> 12);
+
+ Enum_Values : constant array (Test_Enum) of Natural := (8, 12);
+
+ type Test_Enum_Rep is range 1..12;
+ Tmp_Test_Enum_Rep : Test_Enum_Rep;
+ begin
+ Tmp_Test_Enum_Rep := Test_Enum'Enum_Rep (Test_Enum'First);
+ Assert (" 8", Tmp_Test_Enum_Rep'Img);
+
+ for Enum in Test_Enum loop
+ Tmp_Test_Enum_Rep := Test_Enum'Enum_Rep (Enum);
+ Assert (Enum_Values (Enum)'Img, Tmp_Test_Enum_Rep'Img);
+ end loop;
+ end Test_1;
+
+ procedure Test_2 is
+ type Test_Enum is (Enum_1);
+ for Test_Enum use (Enum_1=> 2);
+
+ type Test_Enum_Rep_Full is range 0..2;
+ subtype Test_Enum_Rep_Short is
+ Test_Enum_Rep_Full range 2..Test_Enum_Rep_Full'Last;
+
+ Tmp_Test_Enum_Rep_Full : Test_Enum_Rep_Full;
+ Tmp_Test_Enum_Rep_Short : Test_Enum_Rep_Short;
+
+ begin
+ Tmp_Test_Enum_Rep_Short := Test_Enum'Enum_Rep (Test_Enum'First);
+ Assert (" 2", Tmp_Test_Enum_Rep_Short'Img);
+
+ for Enum in Test_Enum loop
+ Tmp_Test_Enum_Rep_Full := Test_Enum'Enum_Rep (Enum);
+ Assert (" 2", Tmp_Test_Enum_Rep_Short'Img);
+ end loop;
+
+ for Enum in Test_Enum range Test_Enum'First .. Test_Enum'Last loop
+ Tmp_Test_Enum_Rep_Short := Test_Enum'Enum_Rep(Enum); -- Test #2
+ Assert (" 2", Tmp_Test_Enum_Rep_Short'Img);
+ end loop;
+ end Test_2;
+
+begin
+ Test_1;
+ Test_2;
+end;
