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 the manual evaluation of the
name in Expand_N_Subprogram_Renaming_Declaration by a 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.
Tested on x86-64/Linux, applied on the mainline.
2025-11-06 Eric Botcazou <[email protected]>
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.
2025-11-06 Eric Botcazou <[email protected]>
* gnat.dg/renaming19.adb: New test.
* gnat.dg/renaming19_pkg.ads: New helper.
* gnat.dg/renaming19_pkg.adb: Likewise.
--
Eric Botcazoudiff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb
index d2f3df80e00..4e4a6ecd05e 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 2ddf75f1c60..3f9dbe8ade2 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 fe7f311f74c..18418e92a1e 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;
-- { 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;
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;
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;
