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.

diff --git a/gcc/ada/exp_ch2.adb b/gcc/ada/exp_ch2.adb
index d2f3df80e00259d7ef10e936bd11d513f643a8c3..4e4a6ecd05e9fd931c25a1611da1d4f320a2ec70 100644 (file)
--- 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 2ddf75f1c6037d1c4747611419fa7029d69514dd..3f9dbe8ade28334bf4f428ad814a3c222245f558 100644 (file)
--- 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 fe7f311f74ca13de5c8f9c8b1d52ccf5779edf85..18418e92a1e92e7227ea4b3d8bdc51779e23bca5 100644 (file)
--- 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 (file)
index 0000000..7cb5365
--- /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 (file)
index 0000000..19a87aa
--- /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 (file)
index 0000000..77c0f61
--- /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;