From mboxrd@z Thu Jan 1 00:00:00 1970 Return-Path: Received: by sourceware.org (Postfix, from userid 1914) id 0DDB4382C406; Mon, 4 Jul 2022 07:52:10 +0000 (GMT) DKIM-Filter: OpenDKIM Filter v2.11.0 sourceware.org 0DDB4382C406 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-1449] [Ada] Do not make procedure call with only tag-indeternminate actuals dispatching X-Act-Checkin: gcc X-Git-Author: Eric Botcazou X-Git-Refname: refs/heads/master X-Git-Oldrev: 1f03b43fc7552fe105d33612b3b89b4f0b222798 X-Git-Newrev: 8c6bef0a33e32e6a95dca7d50cd5be37e7262775 Message-Id: <20220704075210.0DDB4382C406@sourceware.org> Date: Mon, 4 Jul 2022 07:52:10 +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:10 -0000 https://gcc.gnu.org/g:8c6bef0a33e32e6a95dca7d50cd5be37e7262775 commit r13-1449-g8c6bef0a33e32e6a95dca7d50cd5be37e7262775 Author: Eric Botcazou Date: Thu Jun 2 01:00:48 2022 +0200 [Ada] Do not make procedure call with only tag-indeternminate actuals dispatching The RM 3.9.2(19) clause says that the controlling tag value is statically determined to be the tag of the tagged type involved. As a matter of fact, the call would be made dispatching only as a by-product of the propagation of the controlling tag value to the tag-indeternminate actuals, but that's unnecessary and not done in the equivalent case of a procedure call with both statically tagged and tag-indeternminate actuals. gcc/ada/ * sem_disp.adb (Check_Dispatching_Call): Merge the two special cases where there are no controlling actuals but tag-indeternminate ones. Diff: --- gcc/ada/sem_disp.adb | 77 ++++++++++++++++++++++++---------------------------- 1 file changed, 35 insertions(+), 42 deletions(-) diff --git a/gcc/ada/sem_disp.adb b/gcc/ada/sem_disp.adb index 226142f2b41..ee1d96ec389 100644 --- a/gcc/ada/sem_disp.adb +++ b/gcc/ada/sem_disp.adb @@ -540,8 +540,10 @@ package body Sem_Disp is Control : Node_Id := Empty; Func : Entity_Id; Subp_Entity : Entity_Id; - Indeterm_Ancestor_Call : Boolean := False; - Indeterm_Ctrl_Type : Entity_Id := Empty; -- init to avoid warning + + Indeterm_Ctrl_Type : Entity_Id := Empty; + -- Type of a controlling formal whose actual is a tag-indeterminate call + -- whose result type is different from, but is an ancestor of, the type. Static_Tag : Node_Id := Empty; -- If a controlling formal has a statically tagged actual, the tag of @@ -935,8 +937,7 @@ package body Sem_Disp is and then Base_Type (Etype (Actual)) /= Base_Type (Etype (Formal)) and then Is_Ancestor (Etype (Actual), Etype (Formal)) then - Indeterm_Ancestor_Call := True; - Indeterm_Ctrl_Type := Etype (Formal); + Indeterm_Ctrl_Type := Etype (Formal); -- If the formal is controlling but the actual is not, the type -- of the actual is statically known, and may be used as the @@ -946,39 +947,13 @@ package body Sem_Disp is and then Is_Entity_Name (Actual) and then Is_Tagged_Type (Etype (Actual)) then - Static_Tag := Actual; + Static_Tag := Etype (Actual); end if; Next_Actual (Actual); Next_Formal (Formal); end loop; - -- If the call doesn't have a controlling actual but does have an - -- indeterminate actual that requires dispatching treatment, then an - -- object is needed that will serve as the controlling argument for - -- a dispatching call on the indeterminate actual. This can occur - -- in the unusual situation of a default actual given by a tag- - -- indeterminate call and where the type of the call is an ancestor - -- of the type associated with a containing call to an inherited - -- operation (see AI-239). - - -- Rather than create an object of the tagged type, which would - -- be problematic for various reasons (default initialization, - -- discriminants), the tag of the containing call's associated - -- tagged type is directly used to control the dispatching. - - if No (Control) - and then Indeterm_Ancestor_Call - and then No (Static_Tag) - then - Control := - Make_Attribute_Reference (Loc, - Prefix => New_Occurrence_Of (Indeterm_Ctrl_Type, Loc), - Attribute_Name => Name_Tag); - - Analyze (Control); - end if; - if Present (Control) then -- Verify that no controlling arguments are statically tagged @@ -1030,17 +1005,35 @@ package body Sem_Disp is Check_Direct_Call; - -- If there is a statically tagged actual and a tag-indeterminate - -- call to a function of the ancestor (such as that provided by a - -- default), then treat this as a dispatching call and propagate - -- the tag to the tag-indeterminate call(s). - - elsif Present (Static_Tag) and then Indeterm_Ancestor_Call then - Control := - Make_Attribute_Reference (Loc, - Prefix => - New_Occurrence_Of (Etype (Static_Tag), Loc), - Attribute_Name => Name_Tag); + -- If the call doesn't have a controlling actual but does have an + -- indeterminate actual that requires dispatching treatment, then an + -- object is needed that will serve as the controlling argument for + -- a dispatching call on the indeterminate actual. This can occur + -- in the unusual situation of a default actual given by a tag- + -- indeterminate call and where the type of the call is an ancestor + -- of the type associated with a containing call to an inherited + -- operation (see AI-239). + + -- Rather than create an object of the tagged type, which would + -- be problematic for various reasons (default initialization, + -- discriminants), the tag of the containing call's associated + -- tagged type is directly used to control the dispatching. + + elsif Present (Indeterm_Ctrl_Type) then + if Present (Static_Tag) then + Control := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Static_Tag, Loc), + Attribute_Name => Name_Tag); + + else + Control := + Make_Attribute_Reference (Loc, + Prefix => + New_Occurrence_Of (Indeterm_Ctrl_Type, Loc), + Attribute_Name => Name_Tag); + end if; Analyze (Control);