From 9cc7722674877893d974b1e8018817ecba1e9acf Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Thu, 6 Nov 2025 20:03:49 +0100 Subject: [PATCH] Ada: Fix incorrect renaming of primitive subprogram in object notation It is possible to declare a subprogram renaming whose name is a primitive subprogram in object notation; in this case, the name is unconditionally evaluated in the front-end (unlike for objects) so that, if an ad-hoc body needs to be built for the renaming later, the name is not reevaluated for every call to it. This evaluation is skipped if the name contains an implicit dereference, as reported in the first PR, and the fix is to make the dereference explicit at the end of the processing done in Analyze_Renamed_Primitive_Operation, as is done in the sibling procedure Analyze_Renamed_Entry. The patch also makes a few consistency tweaks to them and also replaces a manual evaluation of the name in Expand_N_Subprogram_Renaming_Declaration by a simple call to Evaluate_Name, which is the procedure used for object renamings. Analyze_Renamed_Primitive_Operation performs the resolution of the name based on the declared profile, but it does not do that correctly in all cases, as reported in the second PR; the fix is again straightforward. gcc/ada/ PR ada/113350 PR ada/113551 * exp_ch2.adb (Expand_Renaming): Fix reference to Evaluate_Name. * exp_ch8.adb (Expand_N_Subprogram_Renaming_Declaration): Call Evaluate_Name to evaluate the name. * sem_ch8.adb (Analyze_Renamed_Entry): Minor tweaks. (Analyze_Renamed_Family_Member): Likewise. (Analyze_Renamed_Primitive_Operation): Likewise. Fix thinko in the function checking profile conformance, save the result of the resolution and make implicit dereferences explicit. gcc/testsuite * gnat.dg/renaming19.adb: New test. * gnat.dg/renaming19_pkg.ads: New helper. * gnat.dg/renaming19_pkg.adb: Likewise. --- gcc/ada/exp_ch2.adb | 3 +- gcc/ada/exp_ch8.adb | 17 +------ gcc/ada/sem_ch8.adb | 64 +++++++++++++----------- gcc/testsuite/gnat.dg/renaming19.adb | 24 +++++++++ gcc/testsuite/gnat.dg/renaming19_pkg.adb | 18 +++++++ gcc/testsuite/gnat.dg/renaming19_pkg.ads | 16 ++++++ 6 files changed, 96 insertions(+), 46 deletions(-) create mode 100644 gcc/testsuite/gnat.dg/renaming19.adb create mode 100644 gcc/testsuite/gnat.dg/renaming19_pkg.adb create mode 100644 gcc/testsuite/gnat.dg/renaming19_pkg.ads diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb index d2f3df80e002..4e4a6ecd05e9 100644 --- a/gcc/ada/exp_ch2.adb +++ b/gcc/ada/exp_ch2.adb @@ -117,8 +117,7 @@ package body Exp_Ch2 is procedure Expand_Renaming (N : Node_Id); -- For renamings, just replace the identifier by the corresponding -- named expression. Note that this has been evaluated (see routine - -- Exp_Ch8.Expand_N_Object_Renaming.Evaluate_Name) so this gives - -- the correct renaming semantics. + -- Exp_Util.Evaluate_Name) so this gives correct renaming semantics. -------------------------- -- Expand_Current_Value -- diff --git a/gcc/ada/exp_ch8.adb b/gcc/ada/exp_ch8.adb index 2ddf75f1c603..3f9dbe8ade28 100644 --- a/gcc/ada/exp_ch8.adb +++ b/gcc/ada/exp_ch8.adb @@ -344,22 +344,9 @@ package body Exp_Ch8 is -- Start of processing for Expand_N_Subprogram_Renaming_Declaration begin - -- When the prefix of the name is a function call, we must force the - -- call to be made by removing side effects from the call, since we - -- must only call the function once. + -- Perform name evaluation in all cases - if Nkind (Nam) = N_Selected_Component - and then Nkind (Prefix (Nam)) = N_Function_Call - then - Remove_Side_Effects (Prefix (Nam)); - - -- For an explicit dereference, the prefix must be captured to prevent - -- reevaluation on calls through the renaming, which could result in - -- calling the wrong subprogram if the access value were to be changed. - - elsif Nkind (Nam) = N_Explicit_Dereference then - Force_Evaluation (Prefix (Nam)); - end if; + Evaluate_Name (Nam); -- Handle cases where we build a body for a renamed equality diff --git a/gcc/ada/sem_ch8.adb b/gcc/ada/sem_ch8.adb index fe7f311f74ca..18418e92a1e9 100644 --- a/gcc/ada/sem_ch8.adb +++ b/gcc/ada/sem_ch8.adb @@ -1873,13 +1873,13 @@ package body Sem_Ch8 is New_S : Entity_Id; Is_Body : Boolean) is - Nam : constant Node_Id := Name (N); - Sel : constant Node_Id := Selector_Name (Nam); - Is_Actual : constant Boolean := Present (Corresponding_Formal_Spec (N)); - Old_S : Entity_Id; + Nam : constant Node_Id := Name (N); + P : constant Node_Id := Prefix (Nam); + + Old_S : Entity_Id; begin - if Entity (Sel) = Any_Id then + if Entity (Selector_Name (Nam)) = Any_Id then -- Selector is undefined on prefix. Error emitted already @@ -1910,10 +1910,11 @@ package body Sem_Ch8 is -- The prefix can be an arbitrary expression that yields a task or -- protected object, so it must be resolved. - if Is_Access_Type (Etype (Prefix (Nam))) then - Insert_Explicit_Dereference (Prefix (Nam)); + if Is_Access_Type (Etype (P)) then + Insert_Explicit_Dereference (P); end if; - Resolve (Prefix (Nam), Scope (Old_S)); + + Resolve (P, Scope (Old_S)); end if; Set_Convention (New_S, Convention (Old_S)); @@ -1924,9 +1925,9 @@ package body Sem_Ch8 is if Is_Protected_Type (Scope (Old_S)) and then Ekind (New_S) = E_Procedure - and then not Is_Variable (Prefix (Nam)) + and then not Is_Variable (P) then - if Is_Actual then + if Present (Corresponding_Formal_Spec (N)) then Error_Msg_N ("target object of protected operation used as actual for " & "formal procedure must be a variable", Nam); @@ -1951,8 +1952,9 @@ package body Sem_Ch8 is New_S : Entity_Id; Is_Body : Boolean) is - Nam : constant Node_Id := Name (N); - P : constant Node_Id := Prefix (Nam); + Nam : constant Node_Id := Name (N); + P : constant Node_Id := Prefix (Nam); + Old_S : Entity_Id; begin @@ -1995,13 +1997,13 @@ package body Sem_Ch8 is New_S : Entity_Id; Is_Body : Boolean) is - Old_S : Entity_Id; - Nam : Entity_Id; + Nam : constant Node_Id := Name (N); + P : constant Node_Id := Prefix (Nam); function Conforms (Subp : Entity_Id; Ctyp : Conformance_Type) return Boolean; - -- Verify that the signatures of the renamed entity and the new entity + -- Verify that the profiles of the renamed entity and the new entity -- match. The first formal of the renamed entity is skipped because it -- is the target object in any subsequent call. @@ -2038,14 +2040,16 @@ package body Sem_Ch8 is Next_Formal (Old_F); end loop; - return True; + return No (Old_F) and then No (New_F); end Conforms; + Old_S : Entity_Id; + -- Start of processing for Analyze_Renamed_Primitive_Operation begin - if not Is_Overloaded (Selector_Name (Name (N))) then - Old_S := Entity (Selector_Name (Name (N))); + if not Is_Overloaded (Selector_Name (Nam)) then + Old_S := Entity (Selector_Name (Nam)); if not Conforms (Old_S, Type_Conformant) then Old_S := Any_Id; @@ -2060,7 +2064,7 @@ package body Sem_Ch8 is begin Old_S := Any_Id; - Get_First_Interp (Selector_Name (Name (N)), Ind, It); + Get_First_Interp (Selector_Name (Nam), Ind, It); while Present (It.Nam) loop if Conforms (It.Nam, Type_Conformant) then @@ -2094,20 +2098,18 @@ package body Sem_Ch8 is -- AI12-0204: The prefix of a prefixed view that is renamed or -- passed as a formal subprogram must be renamable as an object. - Nam := Prefix (Name (N)); - - if Is_Object_Reference (Nam) then - if Is_Dependent_Component_Of_Mutable_Object (Nam) then + if Is_Object_Reference (P) then + if Is_Dependent_Component_Of_Mutable_Object (P) then Error_Msg_N ("illegal renaming of discriminant-dependent component", - Nam); - elsif Depends_On_Mutably_Tagged_Ext_Comp (Nam) then + P); + elsif Depends_On_Mutably_Tagged_Ext_Comp (P) then Error_Msg_N ("illegal renaming of mutably tagged dependent component", - Nam); + P); end if; else - Error_Msg_N ("expect object name in renaming", Nam); + Error_Msg_N ("expect object name in renaming", P); end if; -- Enforce the rule given in (RM 6.3.1 (10.1/2)): a prefixed @@ -2119,12 +2121,16 @@ package body Sem_Ch8 is Set_Convention (New_S, Convention_Intrinsic); end if; - -- Inherit_Renamed_Profile (New_S, Old_S); + Set_Entity (Selector_Name (Nam), Old_S); -- The prefix can be an arbitrary expression that yields an -- object, so it must be resolved. - Resolve (Prefix (Name (N))); + if Is_Access_Type (Etype (P)) then + Insert_Explicit_Dereference (P); + end if; + + Resolve (P); end if; end Analyze_Renamed_Primitive_Operation; diff --git a/gcc/testsuite/gnat.dg/renaming19.adb b/gcc/testsuite/gnat.dg/renaming19.adb new file mode 100644 index 000000000000..7cb5365151d0 --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming19.adb @@ -0,0 +1,24 @@ +-- { dg-do run } + +with Ada.Text_IO; +with Renaming19_Pkg; + +procedure Renaming19 is + + Handler : aliased Renaming19_Pkg.Logging := + (Output => Ada.Text_IO.Current_Output); + + Full_Handler : aliased Renaming19_Pkg.Full_Logging := + (Output => Ada.Text_IO.Current_Output); + + Generic_Handler : access Renaming19_Pkg.Logging'Class := Handler'Access; + + procedure My_Log_3 (Msg : String) renames Generic_Handler.Log; + procedure My_Log_4 (Msg : String; Err : Natural) renames Generic_Handler.Log; + +begin + My_Log_3 ("First"); + Generic_Handler := Full_Handler'Access; + My_Log_3 ("Second"); + My_Log_4 ("Third", 3); +end; diff --git a/gcc/testsuite/gnat.dg/renaming19_pkg.adb b/gcc/testsuite/gnat.dg/renaming19_pkg.adb new file mode 100644 index 000000000000..19a87aaac892 --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming19_pkg.adb @@ -0,0 +1,18 @@ +package body Renaming19_Pkg is + + procedure Log (Handler : Logging; Msg : String) is + begin + Ada.Text_IO.Put_Line (Handler.Output.all, Msg); + end Log; + + procedure Log (Handler : Logging; Msg : String; Err : Natural) is + begin + Ada.Text_IO.Put_Line (Handler.Output.all, Msg & Err'Image); + end Log; + + procedure Log (Handler : Full_Logging; Msg : String) is + begin + raise Program_Error; + end Log; + +end Renaming19_Pkg; diff --git a/gcc/testsuite/gnat.dg/renaming19_pkg.ads b/gcc/testsuite/gnat.dg/renaming19_pkg.ads new file mode 100644 index 000000000000..77c0f61cc646 --- /dev/null +++ b/gcc/testsuite/gnat.dg/renaming19_pkg.ads @@ -0,0 +1,16 @@ +with Ada.Text_IO; + +package Renaming19_Pkg is + + type Logging is tagged record + Output : Ada.Text_IO.File_Access; + end record; + + procedure Log (Handler : Logging; Msg : String); + procedure Log (Handler : Logging; Msg : String; Err : Natural); + + type Full_Logging is new Logging with null record; + + procedure Log (Handler : Full_Logging; Msg : String); + +end Renaming19_Pkg; -- 2.47.3