From: Eric Botcazou <[email protected]>
Note that 'Output and 'Put_Image are also affected since they share a common
implementation with the others.
gcc/ada/ChangeLog:
PR ada/18205
* exp_attr.adb (Rewrite_Attribute_Proc_Call): Skip the conversion to
the formal type only if the actual is of a class-wide type. Generate
a dispatching call when both the prefix is a class-wide type and the
subprogram is a dispatching operation.
(Expand_N_Attribute_Reference) <Input>: Use U_Type consistently and
remove an useless invocation of Root_Type.
<Put_Image>: Minor comment tweak.
<Read>: Likewise.
<Write>: Likewise.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_attr.adb | 37 ++++++++++++++++++++++++-------------
1 file changed, 24 insertions(+), 13 deletions(-)
diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index 403b5899ce5..b299dacebfc 100644
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -2233,6 +2233,8 @@ package body Exp_Attr is
Formal_Typ : constant Entity_Id := Etype (Formal);
Is_Written : constant Boolean := Ekind (Formal) /= E_In_Parameter;
+ Call : Node_Id;
+
begin
-- The expansion depends on Item, the second actual, which is
-- the object being streamed in or out.
@@ -2286,8 +2288,8 @@ package body Exp_Attr is
-- operation is not inherited), we are all set, and can use the
-- argument unchanged.
- if not Is_Class_Wide_Type (Entity (Pref))
- and then not Is_Class_Wide_Type (Etype (Item))
+ if not Is_Class_Wide_Type (Item_Typ)
+ and then not Is_Class_Wide_Type (Formal_Typ)
and then Base_Type (Item_Typ) /= Base_Type (Formal_Typ)
then
-- Perform an unchecked conversion when either the argument or
@@ -2333,11 +2335,21 @@ package body Exp_Attr is
-- And now rewrite the call
- Rewrite (N,
- Make_Procedure_Call_Statement (Loc,
- Name => New_Occurrence_Of (Pname, Loc),
- Parameter_Associations => Exprs));
+ Call := Make_Procedure_Call_Statement (Loc,
+ Name => New_Occurrence_Of (Pname, Loc),
+ Parameter_Associations => Exprs);
+ -- If the attribute has not been specified for a CW type, then we
+ -- must dispatch to the attribute of the specific type identified
+ -- by the tag of Item.
+
+ if Is_Class_Wide_Type (Entity (Pref))
+ and then Is_Dispatching_Operation (Pname)
+ then
+ Set_Controlling_Argument (Call, Item);
+ end if;
+
+ Rewrite (N, Call);
Analyze (N);
end Rewrite_Attribute_Proc_Call;
@@ -4951,9 +4963,9 @@ package body Exp_Attr is
-- Dispatching case with class-wide type
- elsif Is_Class_Wide_Type (P_Type) then
+ elsif Is_Class_Wide_Type (U_Type) then
- if Is_Mutably_Tagged_Type (P_Type) then
+ if Is_Mutably_Tagged_Type (U_Type) then
-- In mutably tagged case, rewrite
-- T'Class'Input (Strm)
@@ -5003,7 +5015,7 @@ package body Exp_Attr is
end if;
Read_Controlling_Tag (P_Type, Cntrl);
- Fname := Find_Prim_Op (Root_Type (P_Type), TSS_Stream_Input);
+ Fname := Find_Prim_Op (U_Type, TSS_Stream_Input);
-- For tagged types, use the primitive Input function
@@ -6642,8 +6654,7 @@ package body Exp_Attr is
end if;
-- Tagged type case, use the primitive Put_Image function. Note
- -- that this will dispatch in the class-wide case which is what we
- -- want.
+ -- that this will dispatch in the class-wide case as required.
elsif Is_Tagged_Type (U_Type) then
Pname := Find_Optional_Prim_Op (U_Type, TSS_Put_Image);
@@ -7064,7 +7075,7 @@ package body Exp_Attr is
end;
-- Tagged type case, use the primitive Read function. Note that
- -- this will dispatch in the class-wide case which is what we want
+ -- this will dispatch in the class-wide case as required.
elsif Is_Tagged_Type (U_Type) then
@@ -8790,7 +8801,7 @@ package body Exp_Attr is
end;
-- Tagged type case, use the primitive Write function. Note that
- -- this will dispatch in the class-wide case which is what we want
+ -- this will dispatch in the class-wide case as required.
elsif Is_Tagged_Type (U_Type) then
--
2.53.0
