Ada: Fix Image for derived enumeration type with representation clause

The problem is that Expand_Image_Attribute incorrectly fetches the root type
for enumeration types, thus bypassing a clause present on the derived type.

The fix is to change the two fields Lit_Indexes and Lit_Strings defined for
enumeration types and subtypes to be formally present on root types only, as
well as to make Expand_Image_Attribute stick to base types.

gcc/ada/
	PR ada/125240
	* gen_il-gen-gen_entities.adb (Enumeration_Kind): Make
	Lit_Indexes and Lit_Strings be defined for root types only.
	* einfo.ads (Lit_Hash): Adjust description.
	(Lit_Indexes): Likewise.
	(Lit_Strings): Likewise.
	(E_Enumeration_Type): Likewise.
	* exp_imgv.adb (Expand_Image_Attribute): Do not fetch the root type
	for enumeration types, except for character types, and adjust.

gcc/testsuite/
	* gnat.dg/enum6.adb: New test.

diff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 9e716c427ab8559cce8f09fa71d6e151aa8677ac..c908542e3e7cfc2994676326cb2657ab82ec1502 100644 (file)
--- a/gcc/ada/einfo.ads
+++ b/gcc/ada/einfo.ads
@@ -3647,22 +3647,19 @@ package Einfo is
 --       type of the object.
 
 --    Lit_Hash [root type only]
---       Defined in enumeration types and subtypes. Non-empty only for the
---       case of an enumeration root type, where it contains the entity for
+--       Defined in enumeration types and subtypes. Contains the entity for
 --       the generated hash function. See unit Exp_Imgv for full details of
 --       the nature and use of this entity for implementing the Value
 --       attribute for the enumeration type in question.
 
---    Lit_Indexes
---       Defined in enumeration types and subtypes. Non-empty only for the
---       case of an enumeration root type, where it contains the entity for
+--    Lit_Indexes [root type only]
+--       Defined in enumeration types and subtypes. Contains the entity for
 --       the generated indexes entity. See unit Exp_Imgv for full details of
 --       the nature and use of this entity for implementing the Image and
 --       Value attributes for the enumeration type in question.
 
---    Lit_Strings
---       Defined in enumeration types and subtypes. Non-empty only for the
---       case of an enumeration root type, where it contains the entity for
+--    Lit_Strings [root type only]
+--       Defined in enumeration types and subtypes. Contains the entity for
 --       the literals string entity. See unit Exp_Imgv for full details of
 --       the nature and use of this entity for implementing the Image and
 --       Value attributes for the enumeration type in question.
@@ -5530,12 +5527,12 @@ package Einfo is
    --  E_Enumeration_Subtype
    --    First_Entity $$$ type
    --    Renamed_Object $$$
-   --    Lit_Strings                          (root type only)
    --    First_Literal
+   --    Lit_Hash                             (root type only)
    --    Lit_Indexes                          (root type only)
+   --    Lit_Strings                          (root type only)
    --    Default_Aspect_Value                 (base type only)
    --    Scalar_Range
-   --    Lit_Hash                             (root type only)
    --    Enum_Pos_To_Rep                      (type only)
    --    Static_Discrete_Predicate
    --    Has_Biased_Representation

diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index 469c7c065da771fc581ea3cceaa9886c106cafa9..082acbe4d88a5a8c50380f762fb9c4ca94c514c2 100644 (file)
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -1061,11 +1061,10 @@ package body Exp_Imgv is
 
       --  Ada 2022 allows 'Image on private types, so fetch the underlying
       --  type to obtain the structure of the type. We use the base type,
-      --  not the root type for discrete types, to handle properly derived
-      --  types, but we use the root type for enumeration types, because the
-      --  literal map is attached to the root. Should be inherited ???
+      --  not the root type, for discrete types in order to handle derived
+      --  types, except for character types for which this is not needed.
 
-      if Is_Real_Type (Ptyp) or else Is_Enumeration_Type (Ptyp) then
+      if Is_Real_Type (Ptyp) or else Is_Character_Type (Ptyp) then
          Rtyp := Underlying_Type (Root_Type (Ptyp));
       else
          Rtyp := Underlying_Type (Base_Type (Ptyp));
@@ -1076,7 +1075,7 @@ package body Exp_Imgv is
 
       Enum_Case := False;
 
-      if Rtyp = Standard_Boolean then
+      if Is_Boolean_Type (Rtyp) then
          --  Use inline expansion if the -gnatd_x switch is not passed to the
          --  compiler. Otherwise expand into a call to the runtime.
 

diff --git a/gcc/ada/gen_il-gen-gen_entities.adb b/gcc/ada/gen_il-gen-gen_entities.adb
index 94a1f04a613acff8f6b5dd01fc49bba655bad36b..bb1dd7a944161994f8a92bab6480e9b9218d122a 100644 (file)
--- a/gcc/ada/gen_il-gen-gen_entities.adb
+++ b/gcc/ada/gen_il-gen-gen_entities.adb
@@ -551,11 +551,11 @@ begin -- Gen_IL.Gen.Gen_Entities
        (Sm (First_Literal, Node_Id),
         Sm (Has_Enumeration_Rep_Clause, Flag),
         Sm (Has_Pragma_Ordered, Flag, Impl_Base_Type_Only),
-        Sm (Lit_Indexes, Node_Id),
-        Sm (Lit_Strings, Node_Id),
+        Sm (Lit_Hash, Node_Id, Root_Type_Only),
+        Sm (Lit_Indexes, Node_Id, Root_Type_Only),
+        Sm (Lit_Strings, Node_Id, Root_Type_Only),
         Sm (Nonzero_Is_True, Flag, Base_Type_Only,
-            Pre => "Root_Type (N) = Standard_Boolean"),
-        Sm (Lit_Hash, Node_Id, Root_Type_Only)));
+            Pre => "Root_Type (N) = Standard_Boolean")));
 
    Cc (E_Enumeration_Type, Enumeration_Kind,
        --  Enumeration types, created by an enumeration type declaration

diff --git a/gcc/testsuite/gnat.dg/enum6.adb b/gcc/testsuite/gnat.dg/enum6.adb
new file mode 100644 (file)
index 0000000..064a3f6
--- /dev/null
+++ b/gcc/testsuite/gnat.dg/enum6.adb
@@ -0,0 +1,43 @@
+--  { dg-do run }
+
+procedure Enum6 is
+
+  type Base_Enum is (Ten, Twenty);
+
+  type Derived_Enum is new Base_Enum;
+  for Derived_Enum use (Ten => 10, Twenty => 20);
+
+  type Rep_Enum is (Ten, Twenty);
+  for Rep_Enum use (Ten => 10, Twenty => 20);
+
+  OK : Boolean := True;
+
+begin
+  for E in Base_Enum loop
+    if (E = Ten and then Base_Enum'Image(E) /= "TEN")
+      or else (E = Twenty and then Base_Enum'Image(E) /= "TWENTY")
+    then
+      OK := False;
+    end if;
+  end loop;
+
+  for E in Derived_Enum loop
+    if (E = Ten and then Derived_Enum'Image(E) /= "TEN")
+       or else (E = Twenty and then Derived_Enum'Image(E) /= "TWENTY")
+    then
+      OK := False;
+    end if;
+  end loop;
+
+  for E in Rep_Enum loop
+    if (E = Ten and then Rep_Enum'Image(E) /= "TEN")
+      or else (E = Twenty and then Rep_Enum'Image(E) /= "TWENTY")
+    then
+      OK := False;
+    end if;
+  end loop;
+
+  if not OK then
+    raise Program_Error;
+  end if;
+end;