[COMMITTED] ada: Spurious error analyzing 'old or 'result in class-wide conditions

Message ID 20230516084110.1502069-1-poulhies@adacore.com
State Accepted
Headers
Series [COMMITTED] ada: Spurious error analyzing 'old or 'result in class-wide conditions |

Checks

Context Check Description
snail/gcc-patch-check success Github commit url

Commit Message

Marc Poulhiès May 16, 2023, 8:41 a.m. UTC
  From: Javier Miranda <miranda@adacore.com>

gcc/ada/

	* sem_attr.adb
	(Analyze_Attribute_Old_Result): When preanalyzing a class-wide
	condition, search in the scopes stack for the subprogram that has
	the condition. This is required because returning the current
	scope causes reporting spurious errors when the occurrence of the
	attribute is found, for example, in a quantified expression.

Tested on x86_64-pc-linux-gnu, committed on master.

---
 gcc/ada/sem_attr.adb | 23 +++++++++++++++++++++--
 1 file changed, 21 insertions(+), 2 deletions(-)
  

Patch

diff --git a/gcc/ada/sem_attr.adb b/gcc/ada/sem_attr.adb
index 452aabdd436..a07e91b839d 100644
--- a/gcc/ada/sem_attr.adb
+++ b/gcc/ada/sem_attr.adb
@@ -1366,8 +1366,27 @@  package body Sem_Attr is
          --  yet on its definite context.
 
          if Inside_Class_Condition_Preanalysis then
-            Legal   := True;
-            Spec_Id := Current_Scope;
+            Legal := True;
+
+            --  Search for the subprogram that has this class-wide condition;
+            --  required to avoid reporting spurious errors since the current
+            --  scope may not be appropriate because the attribute may be
+            --  referenced from the inner scope of, for example, quantified
+            --  expressions.
+
+            --  Although the expression is not installed on its definite
+            --  context, we know that the subprogram has been placed in the
+            --  scope stack by Preanalyze_Condition; we also know that it is
+            --  not a generic subprogram since class-wide pre/postconditions
+            --  can only be applied for primitive operations of tagged types.
+
+            if Is_Subprogram (Current_Scope) then
+               Spec_Id := Current_Scope;
+            else
+               Spec_Id := Enclosing_Subprogram (Current_Scope);
+            end if;
+
+            pragma Assert (Is_Dispatching_Operation (Spec_Id));
             return;
          end if;