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.
Tested on x86-64/Linux, applied on the mainline, 16 and 15 branches.
2026-05-10 Eric Botcazou <[email protected]>
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.
2026-05-10 Eric Botcazou <[email protected]>
* gnat.dg/enum6.adb: New test.
--
Eric Botcazoudiff --git a/gcc/ada/einfo.ads b/gcc/ada/einfo.ads
index 9e716c427ab..c908542e3e7 100644
--- 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 469c7c065da..082acbe4d88 100644
--- 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 94a1f04a613..bb1dd7a9441 100644
--- 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
-- { 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;
