[COMMITTED] ada: Fix crash on body postcondition
Checks
Commit Message
From: Bob Duff <duff@adacore.com>
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.
Tested on x86_64-pc-linux-gnu, committed on master.
---
gcc/ada/exp_attr.adb | 72 +++++-------------------------------
gcc/ada/libgnat/s-valspe.ads | 2 -
gcc/ada/sem_util.adb | 6 ++-
3 files changed, 13 insertions(+), 67 deletions(-)
@@ -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.
@@ -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
@@ -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