sem_res.adb (Resolve_Actuals): If the call is to an overridden operation...

2015-05-22  Ed Schonberg  <schonberg@adacore.com>

	* sem_res.adb (Resolve_Actuals): If the call is to an overridden
	operation, replace the names of the actuals in named associations
	with the names of the actuals of the subprogram that is eventually
	executed. The names of the formals and the defaults can differ
	between the two operations when they are operations of a formal
	derived type.

From-SVN: r223569

diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog
index 15dc2189fe7adef3c89a9303daf3ab83c9c4fd5d..8b3f99f2797eaa547e9734903942aae7702e07a9 100644 (file)
--- a/gcc/ada/ChangeLog
+++ b/gcc/ada/ChangeLog
@@ -1,3 +1,12 @@
+2015-05-22  Ed Schonberg  <schonberg@adacore.com>
+
+       * sem_res.adb (Resolve_Actuals): If the call is to an overridden
+       operation, replace the names of the actuals in named associations
+       with the names of the actuals of the subprogram that is eventually
+       executed. The names of the formals and the defaults can differ
+       between the two operations when they are operations of a formal
+       derived type.
+
 2015-05-22  Bob Duff  <duff@adacore.com>
 
        * a-convec.ads, a-convec.adb (Append): Check for fast path. Split

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index b838e25b4cbadc1b71aa87df7d7521d2bbefa4d0..9d7ddf4fd32913e448446abd6796c6fccc0607d7 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -3050,6 +3050,14 @@ package body Sem_Res is
       F_Typ  : Entity_Id;
       Prev   : Node_Id := Empty;
       Orig_A : Node_Id;
+      Real_F : Entity_Id;
+
+      Real_Subp : Entity_Id;
+      --  If the subprogram being called is an overridden operation,
+      --  Real_Subp is the subprogram that will be called. It may have
+      --  different formal names than the overridden operation, so after
+      --  actual is resolved, the name of the actual in a named association
+      --  must carry the name of the actual of the subprogram being called.
 
       procedure Check_Aliased_Parameter;
       --  Check rules on aliased parameters and related accessibility rules
@@ -3560,12 +3568,27 @@ package body Sem_Res is
       Check_Argument_Order;
       Check_Function_Writable_Actuals (N);
 
+      if Is_Overloadable (Nam)
+        and then Is_Inherited_Operation (Nam)
+        and then Present (Alias (Nam))
+        and then Present (Overridden_Operation (Alias (Nam)))
+      then
+         Real_Subp := Alias (Nam);
+      else
+         Real_Subp := Empty;
+      end if;
+
       if Present (First_Actual (N)) then
          Check_Prefixed_Call;
       end if;
 
       A := First_Actual (N);
       F := First_Formal (Nam);
+
+      if Present (Real_Subp) then
+         Real_F := First_Formal (Real_Subp);
+      end if;
+
       while Present (F) loop
          if No (A) and then Needs_No_Actuals (Nam) then
             null;
@@ -4400,10 +4423,19 @@ package body Sem_Res is
 
               and then not GNATprove_Mode
             then
-               Set_Entity (Selector_Name (Parent (A)), F);
-               Generate_Reference (F, Selector_Name (Parent (A)));
-               Set_Etype (Selector_Name (Parent (A)), F_Typ);
-               Generate_Reference (F_Typ, N, ' ');
+               --  If subprogram is overridden, use name of formal that
+               --  is being called.
+
+               if Present (Real_Subp) then
+                  Set_Entity (Selector_Name (Parent (A)), Real_F);
+                  Set_Etype (Selector_Name (Parent (A)), Etype (Real_F));
+
+               else
+                  Set_Entity (Selector_Name (Parent (A)), F);
+                  Generate_Reference (F, Selector_Name (Parent (A)));
+                  Set_Etype (Selector_Name (Parent (A)), F_Typ);
+                  Generate_Reference (F_Typ, N, ' ');
+               end if;
             end if;
 
             Prev := A;
@@ -4503,6 +4535,10 @@ package body Sem_Res is
 
             Next_Actual (A);
 
+            if Present (Real_Subp) then
+               Next_Formal (Real_F);
+            end if;
+
          --  Case where actual is not present
 
          else