sem_attr.adb (Analyze_Attribute, [...]): Handle properly a quantified expression that appears within a postcondition and...

2011-08-01  Ed Schonberg  <schonberg@adacore.com>

	* sem_attr.adb (Analyze_Attribute, case 'Result): Handle properly a
	quantified expression that appears within a postcondition and uses the
	Ada2012 'Result attribute.

From-SVN: r177001
This commit is contained in:
Ed Schonberg 2011-08-01 08:59:50 +00:00 committed by Arnaud Charlet
parent 57044b5af1
commit 67e28ef818
2 changed files with 26 additions and 7 deletions

View File

@ -1,3 +1,9 @@
2011-08-01 Ed Schonberg <schonberg@adacore.com>
* sem_attr.adb (Analyze_Attribute, case 'Result): Handle properly a
quantified expression that appears within a postcondition and uses the
Ada2012 'Result attribute.
2011-07-28 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE> 2011-07-28 Rainer Orth <ro@CeBiTec.Uni-Bielefeld.DE>
* init.c (__gnat_error_handler): Cast reason to int. * init.c (__gnat_error_handler): Cast reason to int.

View File

@ -3947,14 +3947,29 @@ package body Sem_Attr is
------------ ------------
when Attribute_Result => Result : declare when Attribute_Result => Result : declare
CS : Entity_Id := Current_Scope; CS : Entity_Id;
PS : Entity_Id := Scope (CS); -- The enclosing scope, excluding loops for quantified expressions
PS : Entity_Id;
-- During analysis, CS is the postcondition subprogram and PS the
-- source subprogram to which the postcondition applies. During
-- pre-analysis, CS is the scope of the subprogram declaration.
begin begin
-- Find enclosing scopes, excluding loops
CS := Current_Scope;
while Ekind (CS) = E_Loop loop
CS := Scope (CS);
end loop;
PS := Scope (CS);
-- If the enclosing subprogram is always inlined, the enclosing -- If the enclosing subprogram is always inlined, the enclosing
-- postcondition will not be propagated to the expanded call. -- postcondition will not be propagated to the expanded call.
if Has_Pragma_Inline_Always (PS) if not In_Spec_Expression
and then Has_Pragma_Inline_Always (PS)
and then Warn_On_Redundant_Constructs and then Warn_On_Redundant_Constructs
then then
Error_Msg_N Error_Msg_N
@ -3994,9 +4009,7 @@ package body Sem_Attr is
-- current one. -- current one.
else else
while Present (CS) while Present (CS) and then CS /= Standard_Standard loop
and then CS /= Standard_Standard
loop
if Chars (CS) = Name_uPostconditions then if Chars (CS) = Name_uPostconditions then
exit; exit;
else else
@ -4038,7 +4051,7 @@ package body Sem_Attr is
else else
Error_Attr Error_Attr
("% attribute can only appear" & ("% attribute can only appear" &
" in function Postcondition pragma", P); " in function Postcondition pragma", P);
end if; end if;
end if; end if;
end Result; end Result;