From: Javier Miranda <mira...@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/sem_attr.adb | 37 ++++++++++++++++++++++++++++++++++++-
gcc/ada/sem_util.adb | 12 ++++++++++++
gcc/ada/sem_util.ads | 3 +++
3 files changed, 51 insertions(+), 1 deletion(-)
diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 2fd95f36d65..22fbca45ac5 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 5bea088c44e..438dea79977 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 f282d1fad99..bda295f0a7f 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
--
2.45.1
