From 99b45bbea4dbeb07e0fbc916be28ad006e0f83a7 Mon Sep 17 00:00:00 2001
From: Javier Miranda <miranda@adacore.com>
Date: Sun, 9 Jul 2023 10:58:05 +0000
Subject: [PATCH] ada: Constraint_Error caused by 'Image applied to interface
type
When the prefix of 'Image is used with a class-wide interface
type object, the frontend does not generate code to displace
the pointer to the underlying object to reference its base,
and this is required to invoke Ada.Tags.Wide_Wide_Expanded_Name.
gcc/ada/
* exp_imgv.adb (Rewrite_Object_Image): fix type of formal. Found
reading sources.
(Expand_Wide_Image_Attribute): ditto.
(Expand_Wide_Wide_Image_Attribute): ditto.
(Rewrite_Object_Image): ditto.
* exp_put_image.adb (Build_Image_Call): For class-wide interface
type prefix generate code to displace the pointer to the object to
reference the base of the underlying object.
---
gcc/ada/exp_imgv.adb | 8 ++++----
gcc/ada/exp_put_image.adb | 36 ++++++++++++++++++++++++++++++++----
2 files changed, 36 insertions(+), 8 deletions(-)
diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index a31ce1d8c8fd..6bcfec667a9e 100644
--- a/gcc/ada/exp_imgv.adb
+++ b/gcc/ada/exp_imgv.adb
@@ -61,7 +61,7 @@ package body Exp_Imgv is
procedure Rewrite_Object_Image
(N : Node_Id;
- Pref : Entity_Id;
+ Pref : Node_Id;
Attr_Name : Name_Id;
Str_Typ : Entity_Id);
-- AI12-0124: Rewrite attribute 'Image when it is applied to an object
@@ -1830,7 +1830,7 @@ package body Exp_Imgv is
procedure Expand_Wide_Image_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Pref : constant Entity_Id := Prefix (N);
+ Pref : constant Node_Id := Prefix (N);
Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
Rtyp : Entity_Id;
@@ -1938,7 +1938,7 @@ package body Exp_Imgv is
procedure Expand_Wide_Wide_Image_Attribute (N : Node_Id) is
Loc : constant Source_Ptr := Sloc (N);
- Pref : constant Entity_Id := Prefix (N);
+ Pref : constant Node_Id := Prefix (N);
Rnn : constant Entity_Id := Make_Temporary (Loc, 'S');
Lnn : constant Entity_Id := Make_Temporary (Loc, 'P');
Rtyp : Entity_Id;
@@ -2493,7 +2493,7 @@ package body Exp_Imgv is
procedure Rewrite_Object_Image
(N : Node_Id;
- Pref : Entity_Id;
+ Pref : Node_Id;
Attr_Name : Name_Id;
Str_Typ : Entity_Id)
is
diff --git a/gcc/ada/exp_put_image.adb b/gcc/ada/exp_put_image.adb
index 9eda3231c6b6..0c357f1c5470 100644
--- a/gcc/ada/exp_put_image.adb
+++ b/gcc/ada/exp_put_image.adb
@@ -1190,10 +1190,41 @@ package body Exp_Put_Image is
Parameter_Associations => New_List (Sink_Exp, String_Exp));
end Put_String_Exp;
+ -- Local variables
+
+ Tag_Node : Node_Id;
+
-- Start of processing for Build_Image_Call
begin
if Is_Class_Wide_Type (U_Type) then
+
+ -- For interface types we must generate code to displace the pointer
+ -- to the object to reference the base of the underlying object.
+
+ -- Generate:
+ -- To_Tag_Ptr (Image_Prefix'Address).all
+
+ -- Note that Image_Prefix'Address is recursively expanded into a
+ -- call to Ada.Tags.Base_Address (Image_Prefix'Address).
+
+ if Is_Interface (U_Type) then
+ Tag_Node :=
+ Make_Explicit_Dereference (Loc,
+ Unchecked_Convert_To (RTE (RE_Tag_Ptr),
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Image_Prefix),
+ Attribute_Name => Name_Address)));
+
+ -- Common case
+
+ else
+ Tag_Node :=
+ Make_Attribute_Reference (Loc,
+ Prefix => Duplicate_Subexpr (Image_Prefix),
+ Attribute_Name => Name_Tag);
+ end if;
+
-- Generate qualified-expression syntax; qualification name comes
-- from calling Ada.Tags.Wide_Wide_Expanded_Name.
@@ -1208,10 +1239,7 @@ package body Exp_Put_Image is
(Make_Function_Call (Loc,
Name => New_Occurrence_Of
(RTE (RE_Wide_Wide_Expanded_Name), Loc),
- Parameter_Associations => New_List (
- Make_Attribute_Reference (Loc,
- Prefix => Duplicate_Subexpr (Image_Prefix),
- Attribute_Name => Name_Tag))),
+ Parameter_Associations => New_List (Tag_Node)),
Wide_Wide => True);
Qualification : constant Node_Id :=
--
GitLab