[COMMITTED] ada: Constraint_Error caused by 'Image applied to interface type

[COMMITTED] ada: Constraint_Error caused by 'Image applied to interface type

[Marc Poulhiès]

From: Javier Miranda <miranda@adacore.com>

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.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 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 a31ce1d8c8f..6bcfec667a9 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 9eda3231c6b..0c357f1c547 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 :=
-- 
2.40.0