procyberian/gcc
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

ada: Constraint_Error caused by 'Image applied to interface type

Browse source 
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.
This commit is contained in:
Javier Miranda 2023-07-09 10:58:05 +00:00 • committed by Marc Poulhiès
parent c57fbb120d
commit 99b45bbea4
2 changed files with 36 additions and 8 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
gcc/ada/exp_imgv.adb
View file

@ -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

36
gcc/ada/exp_put_image.adb
View file

@ -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 :=