https://gcc.gnu.org/g:50ffb636ca0553825fa4693f9b6759683a35f94a
commit r15-1263-g50ffb636ca0553825fa4693f9b6759683a35f94a Author: Javier Miranda <mira...@adacore.com> Date: Tue Apr 23 17:30:23 2024 +0000 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. Diff: --- 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 2fd95f36d65c..22fbca45ac5f 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 5bea088c44e2..438dea799778 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 f282d1fad99e..bda295f0a7f8 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