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.

diff --git a/gcc/ada/exp_imgv.adb b/gcc/ada/exp_imgv.adb
index a31ce1d8c8fd69e0f7e070b5c2d21bf74a125b96..6bcfec667a9ea091f0416aa785870f790fb42a32 100644 (file)
--- 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 9eda3231c6b6a6fa1a7b900f8b0c7a4b7ec0dab9..0c357f1c54700f6d2c25915e1619a78d906ca18f 100644 (file)
--- 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 :=