From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id E518A3839C79; Mon, 4 Jul 2022 07:52:04 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org E518A3839C79 MIME-Version: 1.0 Content-Transfer-Encoding: 7bit Content-Type: text/plain; charset="utf-8" From: Pierre-Marie de Rodat To: gcc-cvs@gcc.gnu.org Subject: [gcc r13-1448] [Ada] Fix dispatching call to primitive function with controlling tagged result X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/master X-Git-Oldrev: 4dab9bed7bd173e55fa44b9d8f4a01dfd8566553 X-Git-Newrev: 1f03b43fc7552fe105d33612b3b89b4f0b222798 Message-Id: <20220704075204.E518A3839C79@sourceware.org> Date: Mon, 4 Jul 2022 07:52:04 +0000 (GMT) X-BeenThere: gcc-cvs@gcc.gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: Gcc-cvs mailing list List-Unsubscribe: , List-Archive: List-Help: List-Subscribe: , X-List-Received-Date: Mon, 04 Jul 2022 07:52:05 -0000 https://gcc.gnu.org/g:1f03b43fc7552fe105d33612b3b89b4f0b222798 commit r13-1448-g1f03b43fc7552fe105d33612b3b89b4f0b222798 Author: Eric Botcazou Date: Thu Jun 2 00:45:14 2022 +0200 [Ada] Fix dispatching call to primitive function with controlling tagged result When a dispatching call is made to a primitive function with a controlling tagged result, the call is dispatching on result and thus must return the class-wide type of the tagged type to accommodate all possible results. This was ensured by Expand_Dispatching_Call only in the common case where the result type is the type of the controlling argument, which does not cover the case of a primitive function inherited from an ancestor type. gcc/ada/ * exp_disp.adb (Expand_Dispatching_Call): Fix detection of calls that are dispatching on tagged result. Diff: --- gcc/ada/exp_disp.adb | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) diff --git a/gcc/ada/exp_disp.adb b/gcc/ada/exp_disp.adb index 17043d15510..3ac4b3b4398 100644 --- a/gcc/ada/exp_disp.adb +++ b/gcc/ada/exp_disp.adb @@ -896,8 +896,14 @@ package body Exp_Disp is Copy_Strub_Mode (Subp_Typ, Subp); Set_Convention (Subp_Typ, Convention (Subp)); - if Etype (Subp) = Typ then - Set_Etype (Subp_Typ, CW_Typ); + -- If this is a function and it has a controlling tagged result, then + -- the call is dispatching on result and returns the class-wide type. + + if Ekind (Subp) = E_Function + and then Has_Controlling_Result (Subp) + and then Is_Tagged_Type (Etype (Subp)) + then + Set_Etype (Subp_Typ, Class_Wide_Type (Etype (Subp))); Set_Returns_By_Ref (Subp_Typ, True); else Set_Etype (Subp_Typ, Etype (Subp));