From: Eric Botcazou <ebotcazou@adacore.com>
Date: Tue, 14 Apr 2026 18:52:00 +0000 (+0200)
Subject: ada: Fix missing dispatching for default implementation of S'Class'{Read,Write}
X-Git-Url: http://git.ipfire.org/gitweb/index.cgi?a=commitdiff_plain;h=fe46af8a87f90428ebbe7b1624d76dacfe73cf6f;p=thirdparty%2Fgcc.git

ada: Fix missing dispatching for default implementation of S'Class'{Read,Write}

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

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