From: Pascal Obry <o...@adacore.com>
The output generated by a call to Some_Derived_Composite_Type'Put_Image
(in Ada2022 code) is incomplete in some cases, notably for a type derived
from a container type (i.e., from the Set/Map/List/Vector type declared in
an instance of one of Ada's predefined container generics) with no
user-specified Put_Image procedure.
gcc/ada/
* aspects.ads (Find_Aspect): Add Boolean parameter Or_Rep_Item
(defaulted to False).
* aspects.adb (Find_Aspect): If new Boolean parameter Or_Rep_Item
is True, then instead of returning an empty result if no
appropriate N_Aspect_Specification node is found, return an
appropriate N_Attribute_Definition_Clause if one is found.
* exp_put_image.ads: Change name of Enable_Put_Image function to
Put_Image_Enabled.
* exp_put_image.adb (Build_Record_Put_Image_Procedure): Detect the
case where a call to the Put_Image procedure of a derived type can
be transformed into a call to the parent type's Put_Image
procedure (with a type conversion to the parent type as the actual
parameter).
(Put_Image_Enabled): Change name of function (previously
Enable_Put_Image). Return True in more cases. In particular,
return True for a type with an explicitly specified Put_Image
aspect even if the type is declared in a predefined unit (or in an
instance of a predefined generic unit).
* exp_attr.adb: Changes due to Put_Image_Enabled function name
change.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/aspects.adb | 30 +++++++++++++++++-------
gcc/ada/aspects.ads | 12 ++++++++--
gcc/ada/exp_attr.adb | 4 ++--
gcc/ada/exp_put_image.adb | 48 +++++++++++++++++++++++++++++++++------
gcc/ada/exp_put_image.ads | 2 +-
5 files changed, 76 insertions(+), 20 deletions(-)
diff --git a/gcc/ada/aspects.adb b/gcc/ada/aspects.adb
index c14769c640c..86dbd183565 100644
--- a/gcc/ada/aspects.adb
+++ b/gcc/ada/aspects.adb
@@ -193,13 +193,14 @@ package body Aspects is
function Find_Aspect
(Id : Entity_Id;
A : Aspect_Id;
- Class_Present : Boolean := False) return Node_Id
+ Class_Present : Boolean := False;
+ Or_Rep_Item : Boolean := False) return Node_Id
is
- Decl : Node_Id;
- Item : Node_Id;
- Owner : Entity_Id;
- Spec : Node_Id;
-
+ Decl : Node_Id;
+ Item : Node_Id;
+ Owner : Entity_Id;
+ Spec : Node_Id;
+ Alternative_Rep_Item : Node_Id := Empty;
begin
Owner := Id;
@@ -231,6 +232,18 @@ package body Aspects is
and then Class_Present = Sinfo.Nodes.Class_Present (Item)
then
return Item;
+
+ -- We could do something similar here for an N_Pragma node
+ -- when Get_Aspect_Id (Pragma_Name (Item)) = A, but let's
+ -- wait for a demonstrated need.
+
+ elsif Or_Rep_Item
+ and then not Class_Present
+ and then Nkind (Item) = N_Attribute_Definition_Clause
+ and then Get_Aspect_Id (Chars (Item)) = A
+ then
+ -- Remember this candidate in case we don't find anything better
+ Alternative_Rep_Item := Item;
end if;
Next_Rep_Item (Item);
@@ -266,9 +279,10 @@ package body Aspects is
end if;
-- The entity does not carry any aspects or the desired aspect was not
- -- found.
+ -- found. We have no N_Aspect_Specification node to return, but
+ -- Alternative_Rep_Item may have been set (if Or_Rep_Item is True).
- return Empty;
+ return Alternative_Rep_Item;
end Find_Aspect;
--------------------------
diff --git a/gcc/ada/aspects.ads b/gcc/ada/aspects.ads
index 05677978037..f718227a7af 100644
--- a/gcc/ada/aspects.ads
+++ b/gcc/ada/aspects.ads
@@ -1156,10 +1156,18 @@ package Aspects is
function Find_Aspect (Id : Entity_Id;
A : Aspect_Id;
- Class_Present : Boolean := False) return Node_Id;
+ Class_Present : Boolean := False;
+ Or_Rep_Item : Boolean := False) return Node_Id;
-- Find the aspect specification of aspect A (or A'Class if Class_Present)
-- associated with entity I.
- -- Return Empty if Id does not have the requested aspect.
+ -- If found, then return the aspect specification.
+ -- If not found and Or_Rep_Item is true, then look for a representation
+ -- item (as opposed to an N_Aspect_Specification node) which specifies
+ -- the given aspect; if found, then return the representation item.
+ -- [Currently only N_Attribute_Definition_Clause representation items
+ -- are checked for, but support for detecting N_Pragma representation
+ -- items could easily be added in the future if there is a need.]
+ -- Otherwise, return Empty.
function Find_Value_Of_Aspect
(Id : Entity_Id;
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 6b498eb2d77..dddc05437b4 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -5906,7 +5906,7 @@ package body Exp_Attr is
if No (Pname) then
-- If Put_Image is disabled, call the "unknown" version
- if not Enable_Put_Image (U_Type) then
+ if not Put_Image_Enabled (U_Type) then
Rewrite (N, Build_Unknown_Put_Image_Call (N));
Analyze (N);
return;
@@ -5937,7 +5937,7 @@ package body Exp_Attr is
-- ????Need Find_Optional_Prim_Op instead of Find_Prim_Op,
-- because we might be deriving from a predefined type, which
- -- currently has Enable_Put_Image False.
+ -- currently has Put_Image_Enabled False.
if No (Pname) then
Rewrite (N, Build_Unknown_Put_Image_Call (N));
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 0c357f1c547..6684d4178e6 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -815,7 +815,7 @@ package body Exp_Put_Image is
begin
if Ada_Version < Ada_2022
- or else not Enable_Put_Image (Btyp)
+ or else not Put_Image_Enabled (Btyp)
then
-- generate a very simple Put_Image implementation
@@ -845,6 +845,26 @@ package body Exp_Put_Image is
Parameter_Associations => New_List
(Make_Identifier (Loc, Name_S),
Make_String_Literal (Loc, "(NULL RECORD)"))));
+
+ elsif Is_Derived_Type (Btyp)
+ and then (not Is_Tagged_Type (Btyp) or else Is_Null_Extension (Btyp))
+ then
+ declare
+ Parent_Type : constant Entity_Id := Base_Type (Etype (Btyp));
+ begin
+ Append_To (Stms,
+ Make_Attribute_Reference (Loc,
+ Prefix => New_Occurrence_Of (Parent_Type, Loc),
+ Attribute_Name => Name_Put_Image,
+ Expressions => New_List (
+ Make_Identifier (Loc, Name_S),
+ Make_Type_Conversion (Loc,
+ Subtype_Mark => New_Occurrence_Of
+ (Parent_Type, Loc),
+ Expression => Make_Identifier
+ (Loc, Name_V)))));
+ end;
+
else
Append_To (Stms,
Make_Procedure_Call_Statement (Loc,
@@ -951,11 +971,11 @@ package body Exp_Put_Image is
Entity (Prefix (N)), Append_NUL => False))));
end Build_Unknown_Put_Image_Call;
- ----------------------
- -- Enable_Put_Image --
- ----------------------
+ -----------------------
+ -- Put_Image_Enabled --
+ -----------------------
- function Enable_Put_Image (Typ : Entity_Id) return Boolean is
+ function Put_Image_Enabled (Typ : Entity_Id) return Boolean is
begin
-- If this function returns False for a non-scalar type Typ, then
-- a) calls to Typ'Image will result in calls to
@@ -969,13 +989,13 @@ package body Exp_Put_Image is
-- The name "Sink" here is a short nickname for
-- "Ada.Strings.Text_Buffers.Root_Buffer_Type".
--
+
-- Put_Image does not work for Remote_Types. We check the containing
-- package, rather than the type itself, because we want to include
-- types in the private part of a Remote_Types package.
if Is_Remote_Types (Scope (Typ))
or else Is_Remote_Call_Interface (Typ)
- or else (Is_Tagged_Type (Typ) and then In_Predefined_Unit (Typ))
then
return False;
end if;
@@ -994,6 +1014,20 @@ package body Exp_Put_Image is
return False;
end if;
+ if Is_Tagged_Type (Typ) then
+ if Is_Class_Wide_Type (Typ) then
+ return Put_Image_Enabled (Find_Specific_Type (Base_Type (Typ)));
+ elsif Present (Find_Aspect (Typ, Aspect_Put_Image,
+ Or_Rep_Item => True))
+ then
+ null;
+ elsif Is_Derived_Type (Typ) then
+ return Put_Image_Enabled (Etype (Base_Type (Typ)));
+ elsif In_Predefined_Unit (Typ) then
+ return False;
+ end if;
+ end if;
+
-- ???Disable Put_Image on type Root_Buffer_Type declared in
-- Ada.Strings.Text_Buffers. Note that we can't call Is_RTU on
-- Ada_Strings_Text_Buffers, because it's not known yet (we might be
@@ -1030,7 +1064,7 @@ package body Exp_Put_Image is
end if;
return True;
- end Enable_Put_Image;
+ end Put_Image_Enabled;
-------------------------
-- Make_Put_Image_Name --
diff --git a/gcc/ada/exp_put_image.ads b/gcc/ada/exp_put_image.ads
index a4c94120154..9af4d9e5b23 100644
--- a/gcc/ada/exp_put_image.ads
+++ b/gcc/ada/exp_put_image.ads
@@ -39,7 +39,7 @@ package Exp_Put_Image is
-- are calls to T'Put_Image in different units, there will be duplicates;
-- each unit will get a copy of the T'Put_Image procedure.
- function Enable_Put_Image (Typ : Entity_Id) return Boolean;
+ function Put_Image_Enabled (Typ : Entity_Id) return Boolean;
-- True if the predefined Put_Image should be enabled for type T. Put_Image
-- is always enabled if there is a user-specified one.
--
2.40.0
