ada: Tune handling of attributes Old in contract Exceptional_Cases

Contract Exceptional_Cases allows formal parameters to appear *in*
prefixes of attributes Old, but the code only allowed them to appear
*as* prefixes of those attributes.

For example, we now accetp expressions like "X.all'Old" that were
previously rejected.

gcc/ada/

	* sem_res.adb (Resolve_Entity_Name): Tune handling of formal parameters
	in contract Exceptional_Cases.

diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb
index 17228689364810edf784e97d51700ae0daf1a8b5..9161218a32b578247fb9f8b58cf2454282e3f2a3 100644 (file)
--- a/gcc/ada/sem_res.adb
+++ b/gcc/ada/sem_res.adb
@@ -7832,6 +7832,9 @@ package body Sem_Res is
       --  Determine whether Expr is part of an N_Attribute_Reference
       --  expression.
 
+      function In_Attribute_Old (Expr : Node_Id) return Boolean;
+      --  Determine whether Expr is in attribute Old
+
       function Within_Exceptional_Cases_Consequence
         (Expr : Node_Id)
          return Boolean;
@@ -7878,6 +7881,31 @@ package body Sem_Res is
          end if;
       end Is_Assignment_Or_Object_Expression;
 
+      ----------------------
+      -- In_Attribute_Old --
+      ----------------------
+
+      function In_Attribute_Old (Expr : Node_Id) return Boolean is
+         N : Node_Id := Expr;
+      begin
+         while Present (N) loop
+            if Nkind (N) = N_Attribute_Reference
+              and then Attribute_Name (N) = Name_Old
+            then
+               return True;
+
+            --  Prevent the search from going too far
+
+            elsif Is_Body_Or_Package_Declaration (N) then
+               return False;
+            end if;
+
+            N := Parent (N);
+         end loop;
+
+         return False;
+      end In_Attribute_Old;
+
       -----------------------------
       -- Is_Attribute_Expression --
       -----------------------------
@@ -8080,12 +8108,12 @@ package body Sem_Res is
 
             --  Parameters of modes OUT or IN OUT of the subprogram shall not
             --  occur in the consequences of an exceptional contract unless
-            --  they either are of a by-reference type or occur in the prefix
+            --  they are either passed by reference or occur in the prefix
             --  of a reference to the 'Old attribute.
 
             if Ekind (E) in E_Out_Parameter | E_In_Out_Parameter
               and then Within_Exceptional_Cases_Consequence (N)
-              and then not Is_Attribute_Old (Parent (N))
+              and then not In_Attribute_Old (N)
               and then not Is_By_Reference_Type (Etype (E))
               and then not Is_Aliased (E)
             then