ada: Missing support for 'Old with overloaded function

The compiler reports an error when the prefix of 'Old is
a call to an overloaded function that has no parameters.

gcc/ada/

	* sem_attr.adb (Analyze_Attribute): Enhance support for
	using 'Old with a prefix that references an overloaded
	function that has no parameters; add missing support
	for the use of 'Old within qualified expressions.

	* sem_util.ads (Preanalyze_And_Resolve_Without_Errors):
	New subprogram.

	* sem_util.adb (Preanalyze_And_Resolve_Without_Errors):
	New subprogram.

3 files changed, 51 insertions, 1 deletions

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 2fd95f3..22fbca4 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -5534,7 +5534,42 @@ package body Sem_Attr is
          --  The prefix must be preanalyzed as the full analysis will take
          --  place during expansion.
 
-         Preanalyze_And_Resolve (P);
+         --  If the attribute reference has an expected type or shall resolve
+         --  to a given type, the same applies to the prefix; otherwise the
+         --  prefix shall be resolved independently of context (RM 6.1.1(8/5)).
+
+         if Nkind (Parent (N)) = N_Qualified_Expression then
+            Preanalyze_And_Resolve (P, Etype (Parent (N)));
+
+         --  An special case occurs when the prefix is an overloaded function
+         --  call without formals; in order to identify such case we preanalyze
+         --  a duplicate of the prefix ignoring errors.
+
+         else
+            declare
+               P_Copy : constant Node_Id := New_Copy_Tree (P);
+
+            begin
+               Set_Parent (P_Copy, Parent (P));
+
+               Preanalyze_And_Resolve_Without_Errors (P_Copy);
+
+               --  In the special case of a call to an overloaded function
+               --  without extra formals we resolve it using its returned
+               --  type (which is the unique valid call); if this not the
+               --  case we will report the error later, as part of the
+               --  regular analysis of the full expression.
+
+               if Nkind (P_Copy) = N_Function_Call
+                 and then Is_Overloaded (Name (P_Copy))
+                 and then No (First_Formal (Entity (Name (P_Copy))))
+               then
+                  Preanalyze_And_Resolve (P, Etype (Name (P_Copy)));
+               else
+                  Preanalyze_And_Resolve (P);
+               end if;
+            end;
+         end if;
 
          --  Ensure that the prefix does not contain attributes 'Old or 'Result
 
diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 5bea088..438dea7 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -25790,6 +25790,18 @@ package body Sem_Util is
       return Kind;
    end Policy_In_Effect;
 
+   -------------------------------------------
+   -- Preanalyze_And_Resolve_Without_Errors --
+   -------------------------------------------
+
+   procedure Preanalyze_And_Resolve_Without_Errors (N : Node_Id) is
+      Status : constant Boolean := Get_Ignore_Errors;
+   begin
+      Set_Ignore_Errors (True);
+      Preanalyze_And_Resolve (N);
+      Set_Ignore_Errors (Status);
+   end Preanalyze_And_Resolve_Without_Errors;
+
    -------------------------------
    -- Preanalyze_Without_Errors --
    -------------------------------
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index f282d1f..bda295f 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -3388,6 +3388,9 @@ package Sem_Util is
    function Yields_Universal_Type (N : Node_Id) return Boolean;
    --  Determine whether unanalyzed node N yields a universal type
 
+   procedure Preanalyze_And_Resolve_Without_Errors (N : Node_Id);
+   --  Preanalyze and resolve N without reporting errors
+
    procedure Preanalyze_Without_Errors (N : Node_Id);
    --  Preanalyze N without reporting errors