ada: Fix crash on body postcondition

This patch fixes a bug where the compiler could crash on a postcondition
on a subprogram body (i.e. a body that "acts as spec"), if the
postcondition contains 'Old attributes that use the Ada 2022 feature
that allows certain conditionals (see RM-6.1.1).

The main bug fix here is in exp_attr.adb to set Ins_Node properly in the
Acts_As_Spec case. Otherwise, the initialization of the 'Old temp would
occur before the declaration, which gigi does not like.

gcc/ada/

	* exp_attr.adb (Attribute_Old): The 'Old attribute we are
	processing here is in a postcondition, which cannot be inside the
	"Wrapped_Statements" of the subprogram with that postcondition. So
	remove the loop labeled "Climb the parent chain looking for
	subprogram _Wrapped_Statements". The only way this loop could find
	a Subp is if we are nested inside a subprogram that also has a
	postcondition, and in that case we would find the wrong (outer)
	one. In any case, Subp is set to Empty after the loop, so all
	subsequent tests for Present (Subp) are necessarily False; remove
	them and the corresponding code. Set Ins_Node unconditionally (to
	the right thing). Remove obsolete comments.
	* sem_util.adb (Determining_Expressions): Fix assertion;
	Pragma_Test_Case was missing.
	(Eligible_For_Conditional_Evaluation): Fix assert that could fail
	in case of errors.
	* libgnat/s-valspe.ads: Remove pragma Unevaluated_Use_Of_Old;
	there are no uses of 'Old in this package.

diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb
index a8e06f0005ee8569410ac697c24115943c385568..63b311c1b89010473fb68d266600bb02a52e28a3 100644 (file)
--- a/gcc/ada/exp_attr.adb
+++ b/gcc/ada/exp_attr.adb
@@ -4988,7 +4988,6 @@ package body Exp_Attr is
          CW_Typ  : Entity_Id;
          Decl    : Node_Id;
          Ins_Nod : Node_Id;
-         Subp    : Node_Id;
          Temp    : Entity_Id;
 
          use Old_Attr_Util.Conditional_Evaluation;
@@ -5007,27 +5006,6 @@ package body Exp_Attr is
             return;
          end if;
 
-         --  Climb the parent chain looking for subprogram _Wrapped_Statements
-
-         Subp := N;
-         while Present (Subp) loop
-            exit when Nkind (Subp) = N_Subprogram_Body
-              and then Chars (Defining_Entity (Subp))
-                         = Name_uWrapped_Statements;
-
-            --  If assertions are disabled, no need to create the declaration
-            --  that preserves the value. The postcondition pragma in which
-            --  'Old appears will be checked or disabled according to the
-            --  current policy in effect.
-
-            if Nkind (Subp) = N_Pragma and then not Is_Checked (Subp) then
-               return;
-            end if;
-
-            Subp := Parent (Subp);
-         end loop;
-         Subp := Empty;
-
          --  'Old can only appear in the case where local contract-related
          --  wrapper has been generated with the purpose of wrapping the
          --  original declarations and statements.
@@ -5040,44 +5018,20 @@ package body Exp_Attr is
          Mutate_Ekind (Temp, E_Constant);
          Set_Stores_Attribute_Old_Prefix (Temp);
 
-         --  Push the scope of the related subprogram where _Postcondition
-         --  resides as this ensures that the object will be analyzed in the
-         --  proper context.
-
-         if Present (Subp) then
-            Push_Scope (Scope (Defining_Entity (Subp)));
-
-         --  No need to push the scope when generating C code since the
-         --  _Postcondition procedure has been inlined.
-
-         else
-            null;
-         end if;
-
          --  Locate the insertion place of the internal temporary that saves
          --  the 'Old value.
 
-         if Present (Subp) then
-            Ins_Nod := Subp;
+         Ins_Nod := N;
+         while Nkind (Ins_Nod) /= N_Subprogram_Body loop
+            Ins_Nod := Parent (Ins_Nod);
+         end loop;
 
-         --  General case where the postcondition checks occur after the call
-         --  to _Wrapped_Statements.
+         pragma Assert (Present (Wrapped_Statements
+           (if Acts_As_Spec (Ins_Nod)
+              then Defining_Unit_Name (Specification (Ins_Nod))
+              else Corresponding_Spec (Ins_Nod))));
 
-         else
-            Ins_Nod := N;
-            while Nkind (Ins_Nod) /= N_Subprogram_Body loop
-               Ins_Nod := Parent (Ins_Nod);
-            end loop;
-
-            if Present (Corresponding_Spec (Ins_Nod))
-              and then Present
-                         (Wrapped_Statements (Corresponding_Spec (Ins_Nod)))
-            then
-               Ins_Nod := Last (Declarations (Ins_Nod));
-            else
-               Ins_Nod := First (Declarations (Ins_Nod));
-            end if;
-         end if;
+         Ins_Nod := Last (Declarations (Ins_Nod));
 
          if Eligible_For_Conditional_Evaluation (N) then
             declare
@@ -5122,10 +5076,6 @@ package body Exp_Attr is
                              (Temp => Temp,
                               Typ  => Etype (Pref),
                               Loc  => Loc));
-
-               if Present (Subp) then
-                  Pop_Scope;
-               end if;
                return;
             end;
 
@@ -5179,10 +5129,6 @@ package body Exp_Attr is
 
          end if;
 
-         if Present (Subp) then
-            Pop_Scope;
-         end if;
-
          --  Ensure that the prefix of attribute 'Old is valid. The check must
          --  be inserted after the expansion of the attribute has taken place
          --  to reflect the new placement of the prefix.

diff --git a/gcc/ada/libgnat/s-valspe.ads b/gcc/ada/libgnat/s-valspe.ads
index 016e1df1aab0a21b4d7ba1416ecf24ce0e254b89..d51f68096a206bb15bca8f9c5fdf8a268df638ef 100644 (file)
--- a/gcc/ada/libgnat/s-valspe.ads
+++ b/gcc/ada/libgnat/s-valspe.ads
@@ -48,8 +48,6 @@ package System.Val_Spec with
   Pure,
   Ghost
 is
-   pragma Unevaluated_Use_Of_Old (Allow);
-
    function Only_Space_Ghost (S : String; From, To : Integer) return Boolean is
       (for all J in From .. To => S (J) = ' ')
    with

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index d629c76fd473763aceb02caa0cc72735d72a2214..ebfe27a9bea28af8c2b7d0c3aeba2da4aeafd0bd 100644 (file)
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -30562,7 +30562,8 @@ package body Sem_Util is
                               | Pragma_Post
                               | Pragma_Postcondition
                               | Pragma_Post_Class
-                              | Pragma_Refined_Post);
+                              | Pragma_Refined_Post
+                              | Pragma_Test_Case);
 
                            return (1 .. 0 => <>); -- recursion terminates here
                         end if;
@@ -30619,7 +30620,8 @@ package body Sem_Util is
                   Determiners : constant Determining_Expression_List :=
                     Determining_Expressions (Expr);
                begin
-                  pragma Assert (Determiners'Length > 0);
+                  pragma Assert (if Serious_Errors_Detected = 0 then
+                                   Determiners'Length > 0);
 
                   for Idx in Determiners'Range loop
                      if not Is_Known_On_Entry (Determiners (Idx).Expr) then