Skip to content

R
riscv-gcc-1
Commit ed7b9d6e by Arnaud Charlet
Options

[multiple changes] 

2012-11-06  Hristian Kirtchev  <kirtchev@adacore.com>

	* exp_prag.adb (Expand_Pragma_Loop_Assertion): Update the comment
	on intended expansion.	Reimplement the logic which expands the
	termination variants.
	(Process_Increase_Decrease): Update the parameter profile and the
	comment related to it. Accommodate the new aggregate-like appearance of
	the termination variants.
	* sem_prag.adb (Analyze_Pragma): Update the syntax of pragma
	Loop_Assertion. Reimplement the semantic analysis of the pragma
	to accommodate the new aggregate-like variant.
	(Check_Variant): New routine.
	* snames.ads-tmpl: Change names Name_Decreases and Name_Increases
	to Name_Decreasing and Name_Increasing respectively. Add name
	Variant.

2012-11-06  Ed Schonberg  <schonberg@adacore.com>

	* sem_eval.adb: Static evaluation of case expressions.

From-SVN: r193216
parent 2fe2920e
Showing with 242 additions and 86 deletions
gcc/ada/ChangeLog
2012-11-06 Hristian Kirtchev <kirtchev@adacore.com>
* exp_prag.adb (Expand_Pragma_Loop_Assertion): Update the comment
on intended expansion. Reimplement the logic which expands the
termination variants.
(Process_Increase_Decrease): Update the parameter profile and the
comment related to it. Accommodate the new aggregate-like appearance of
the termination variants.
* sem_prag.adb (Analyze_Pragma): Update the syntax of pragma
Loop_Assertion. Reimplement the semantic analysis of the pragma
to accommodate the new aggregate-like variant.
(Check_Variant): New routine.
* snames.ads-tmpl: Change names Name_Decreases and Name_Increases
to Name_Decreasing and Name_Increasing respectively. Add name
Variant.
2012-11-06 Ed Schonberg <schonberg@adacore.com>
* sem_eval.adb: Static evaluation of case expressions.
2012-11-06 Robert Dewar <dewar@adacore.com>
* exp_prag.adb, impunit.adb, exp_ch9.adb, par-ch4.adb,
......
gcc/ada/exp_prag.adb
......@@ -807,8 +807,8 @@ package body Exp_Prag is
-- <preceding source statements>
-- pragma Loop_Assertion
-- (Invariant => Invar_Expr,
-- Increases => Incr_Expr,
-- Decreases => Decr_Expr);
-- Variant => (Increasing => Incr_Expr,
-- Decreasing => Decr_Expr));
-- <succeeding source statements>
-- end loop;
......@@ -855,15 +855,20 @@ package body Exp_Prag is
Loop_Stmt : Node_Id;
Old_Assign : List_Id := No_List;
procedure Process_Increase_Decrease (Arg : Node_Id; Is_Last : Boolean);
-- Process a single increases/decreases expression. Flag Is_Last should
-- be set when the expression is the last argument to be processed.
procedure Process_Increase_Decrease
(Variant : Node_Id;
Is_Last : Boolean);
-- Process a single increasing / decreasing termination variant. Flag
-- Is_Last should be set when processing the last variant.
-------------------------------
-- Process_Increase_Decrease --
-------------------------------
procedure Process_Increase_Decrease (Arg : Node_Id; Is_Last : Boolean) is
procedure Process_Increase_Decrease
(Variant : Node_Id;
Is_Last : Boolean)
is
function Make_Op
(Loc : Source_Ptr;
Curr_Val : Node_Id;
......@@ -880,26 +885,21 @@ package body Exp_Prag is
Curr_Val : Node_Id;
Old_Val : Node_Id) return Node_Id
is
Modif : constant Node_Id := First (Choices (Variant));
begin
if Chars (Arg) = Name_Increases then
return
Make_Op_Gt (Loc,
Left_Opnd => Curr_Val,
Right_Opnd => Old_Val);
else pragma Assert (Chars (Arg) = Name_Decreases);
return
Make_Op_Lt (Loc,
Left_Opnd => Curr_Val,
Right_Opnd => Old_Val);
if Chars (Modif) = Name_Increasing then
return Make_Op_Gt (Loc, Curr_Val, Old_Val);
else pragma Assert (Chars (Modif) = Name_Decreasing);
return Make_Op_Lt (Loc, Curr_Val, Old_Val);
end if;
end Make_Op;
-- Local variables
Expr : constant Node_Id := Expression (Arg);
Expr : constant Node_Id := Expression (Variant);
Loc : constant Source_Ptr := Sloc (Expr);
Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt);
Cond : Node_Id;
Curr_Id : Entity_Id;
Old_Id : Entity_Id;
Prag : Node_Id;
......@@ -909,7 +909,8 @@ package body Exp_Prag is
begin
-- All temporaries generated in this routine must be inserted before
-- the related loop statement. Ensure that the proper scope is on the
-- stack when analyzing the temporaries.
-- stack when analyzing the temporaries. Note that we also use the
-- Sloc of the related loop.
Push_Scope (Scope (Loop_Scop));
......@@ -930,6 +931,21 @@ package body Exp_Prag is
New_Reference_To (Standard_Boolean, Loop_Loc),
Expression =>
New_Reference_To (Standard_False, Loop_Loc)));
-- Prevent an unwanted optimization where the Current_Value of
-- the flag eliminates the if statement which stores the variant
-- values coming from the previous iteration.
-- Flag : Boolean := False;
-- loop
-- if Flag then -- condition rewritten to False
-- Old_N := Curr_N; -- and if statement eliminated
-- end if;
-- . . .
-- Flag := True;
-- end loop;
Set_Current_Value (Flag_Id, Empty);
end if;
-- Step 2: Create the temporaries which store the old and current
......@@ -1008,16 +1024,22 @@ package body Exp_Prag is
-- if Curr /= Old then
-- <Prag>;
Cond :=
Make_Op_Ne (Loc,
Left_Opnd => New_Reference_To (Curr_Id, Loc),
Right_Opnd => New_Reference_To (Old_Id, Loc));
if No (If_Stmt) then
-- When there is just one termination variant, do not compare the
-- old and current value for equality, just check the pragma.
if Is_Last then
If_Stmt := Prag;
else
If_Stmt :=
Make_If_Statement (Loc,
Condition => Cond,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Reference_To (Curr_Id, Loc),
Right_Opnd => New_Reference_To (Old_Id, Loc)),
Then_Statements => New_List (Prag));
end if;
-- Generate:
-- else
......@@ -1038,15 +1060,16 @@ package body Exp_Prag is
Append_To (Elsif_Parts (If_Stmt),
Make_Elsif_Part (Loc,
Condition => Cond,
Condition =>
Make_Op_Ne (Loc,
Left_Opnd => New_Reference_To (Curr_Id, Loc),
Right_Opnd => New_Reference_To (Old_Id, Loc)),
Then_Statements => New_List (Prag)));
end if;
end Process_Increase_Decrease;
-- Local variables
Args : constant List_Id := Pragma_Argument_Associations (N);
Last_Arg : constant Node_Id := Last (Args);
Arg : Node_Id;
Invar : Node_Id := Empty;
......@@ -1055,14 +1078,6 @@ package body Exp_Prag is
begin
-- Locate the enclosing loop for which this assertion applies
Loop_Scop := Current_Scope;
while Present (Loop_Scop)
and then Loop_Scop /= Standard_Standard
and then Ekind (Loop_Scop) /= E_Loop
loop
Loop_Scop := Scope (Loop_Scop);
end loop;
Loop_Stmt := N;
while Present (Loop_Stmt)
and then Nkind (Loop_Stmt) /= N_Loop_Statement
......@@ -1070,14 +1085,35 @@ package body Exp_Prag is
Loop_Stmt := Parent (Loop_Stmt);
end loop;
Loop_Scop := Entity (Identifier (Loop_Stmt));
-- Process all pragma arguments
Arg := First (Args);
Arg := First (Pragma_Argument_Associations (N));
while Present (Arg) loop
if Chars (Arg) = Name_Increases
or else Chars (Arg) = Name_Decreases
then
Process_Increase_Decrease (Arg, Is_Last => Arg = Last_Arg);
-- Termination variants appear as components in an aggregate
if Chars (Arg) = Name_Variant then
declare
Variants : constant Node_Id := Expression (Arg);
Last_Var : constant Node_Id :=
Last (Component_Associations (Variants));
Variant : Node_Id;
begin
Variant := First (Component_Associations (Variants));
while Present (Variant) loop
Process_Increase_Decrease
(Variant => Variant,
Is_Last => Variant = Last_Var);
Next (Variant);
end loop;
end;
-- Invariant
else
Invar := Expression (Arg);
end if;
......@@ -1088,13 +1124,19 @@ package body Exp_Prag is
-- Verify the invariant expression, generate:
-- pragma Assert (<Invar>);
-- Use the Sloc of the invariant for better error reporting
if Present (Invar) then
declare
Invar_Loc : constant Source_Ptr := Sloc (Invar);
begin
Insert_Action (N,
Make_Pragma (Loc,
Make_Pragma (Invar_Loc,
Chars => Name_Assert,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Loc,
Make_Pragma_Argument_Association (Invar_Loc,
Expression => Relocate_Node (Invar)))));
end;
end if;
-- Construct the segment which stores the old values of all expressions.
......@@ -1135,7 +1177,8 @@ package body Exp_Prag is
Expression => New_Reference_To (Standard_True, Loc)))));
end if;
-- Need a comment on this final rewrite ???
-- The original pragma has been transformed into a complex sequence of
-- statements and does not need to remain in the tree.
Rewrite (N, Make_Null_Statement (Loc));
Analyze (N);
......
gcc/ada/sem_eval.adb
......@@ -1759,21 +1759,63 @@ package body Sem_Eval is
-- Eval_Case_Expression --
--------------------------
-- Right now we do not attempt folding of any case expressions, and the
-- language does not require it, so the only required processing is to
-- do the check for all expressions appearing in the case expression.
-- A conditional expression is static if all its conditions and dependent
-- expressions are static.
procedure Eval_Case_Expression (N : Node_Id) is
Alt : Node_Id;
Choice : Node_Id;
Is_Static : Boolean;
Result : Node_Id;
Val : Uint;
begin
Result := Empty;
Is_Static := True;
if Is_Static_Expression (Expression (N)) then
Val := Expr_Value (Expression (N));
else
Check_Non_Static_Context (Expression (N));
Is_Static := False;
end if;
Alt := First (Alternatives (N));
while Present (Alt) loop
Search : while Present (Alt) loop
if not Is_Static
or else not Is_Static_Expression (Expression (Alt))
then
Check_Non_Static_Context (Expression (Alt));
Next (Alt);
Is_Static := False;
else
Choice := First (Discrete_Choices (Alt));
while Present (Choice) loop
if Nkind (Choice) = N_Others_Choice then
Result := Expression (Alt);
exit Search;
elsif Expr_Value (Choice) = Val then
Result := Expression (Alt);
exit Search;
else
Next (Choice);
end if;
end loop;
end if;
Next (Alt);
end loop Search;
if Is_Static then
Rewrite (N, Relocate_Node (Result));
else
Set_Is_Static_Expression (N, False);
end if;
end Eval_Case_Expression;
------------------------
......
gcc/ada/sem_prag.adb
......@@ -11288,18 +11288,71 @@ package body Sem_Prag is
-- Loop_Assertion --
--------------------
-- pragma Loop_Assertion (
-- [[Invariant =>] boolean_EXPRESSION],
-- {CHANGE_MODE => discrete_EXPRESSION} );
-- pragma Loop_Assertion
-- ( [Invariant =>] boolean_Expression
-- | [Invariant =>] boolean_Expression ,
-- Variant => TERMINATION_VARIANTS
-- | Variant => TERMINATION_VARIANTS );
--
-- CHANGE_MODE ::= Increases | Decreases
-- TERMINATION_VARIANTS ::=
-- ( TERMINATION_VARIANT {, TERMINATION_VARIANT} )
--
-- TERMINATION_VARIANT ::= CHANGE_MODIFIER => discrete_EXPRESSION
--
-- CHANGE_MODIFIER ::= Increasing | Decreasing
when Pragma_Loop_Assertion => Loop_Assertion : declare
Arg : Node_Id;
Expr : Node_Id;
Seen : Boolean := False;
procedure Check_Variant (Arg : Node_Id);
-- Verify the legality of a variant
-------------------
-- Check_Variant --
-------------------
procedure Check_Variant (Arg : Node_Id) is
Expr : constant Node_Id := Expression (Arg);
begin
-- Variants appear in aggregate form
if Nkind (Expr) = N_Aggregate then
declare
Comp : Node_Id;
Extra : Node_Id;
Modif : Node_Id;
begin
Comp := First (Component_Associations (Expr));
while Present (Comp) loop
Modif := First (Choices (Comp));
Extra := Next (Modif);
Check_Arg_Is_One_Of
(Modif, Name_Decreasing, Name_Increasing);
if Present (Extra) then
Error_Pragma_Arg
("only one modifier allowed in argument", Expr);
end if;
Preanalyze_And_Resolve
(Expression (Comp), Any_Discrete);
Next (Comp);
end loop;
end;
else
Error_Pragma_Arg
("expression on variant must be an aggregate", Expr);
end if;
end Check_Variant;
-- Local variables
Stmt : Node_Id;
-- Start of processing for Loop_Assertion
begin
GNAT_Pragma;
S14_Pragma;
......@@ -11324,46 +11377,43 @@ package body Sem_Prag is
end if;
Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (2);
-- Process the arguments
Arg := Arg1;
while Present (Arg) loop
Expr := Expression (Arg);
-- Process the first argument
-- All expressions are preanalyzed because they will be
-- relocated during expansion and analyzed in their new
-- context.
if Chars (Arg1) = Name_Variant then
Check_Variant (Arg1);
if Chars (Arg) = Name_Invariant
or else
(Arg_Count = 1
and then Chars (Arg) /= Name_Increases
and then Chars (Arg) /= Name_Decreases)
elsif Chars (Arg1) = No_Name
or else Chars (Arg1) = Name_Invariant
then
-- Only one invariant is allowed in the pragma
Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean);
if Seen then
Error_Pragma_Arg
("only one invariant allowed in pragma %", Arg);
else
Seen := True;
Preanalyze_And_Resolve (Expr, Any_Boolean);
Error_Pragma_Arg ("argument not allowed in pragma %", Arg1);
end if;
elsif Chars (Arg) = Name_Increases
or else Chars (Arg) = Name_Decreases
then
Preanalyze_And_Resolve (Expr, Any_Discrete);
-- Process the second argument
-- Illegal argument
if Present (Arg2) then
if Chars (Arg2) = Name_Variant then
if Chars (Arg1) = Name_Variant then
Error_Pragma ("only one variant allowed in pragma %");
else
Check_Variant (Arg2);
end if;
elsif Chars (Arg2) = Name_Invariant then
if Chars (Arg1) = Name_Variant then
Error_Pragma_Arg ("invariant must precede variant", Arg2);
else
Error_Pragma_Arg ("argument not allowed in pragma %", Arg);
Error_Pragma ("only one invariant allowed in pragma %");
end if;
Next (Arg);
end loop;
else
Error_Pragma_Arg ("argument not allowed in pragma %", Arg2);
end if;
end if;
end Loop_Assertion;
-----------------------
......
gcc/ada/snames.ads-tmpl
......@@ -671,7 +671,7 @@ package Snames is
Name_Component_Size_4 : constant Name_Id := N + $;
Name_Copy : constant Name_Id := N + $;
Name_D_Float : constant Name_Id := N + $;
Name_Decreases : constant Name_Id := N + $;
Name_Decreasing : constant Name_Id := N + $;
Name_Descriptor : constant Name_Id := N + $;
Name_Disable : constant Name_Id := N + $;
Name_Dot_Replacement : constant Name_Id := N + $;
......@@ -691,7 +691,7 @@ package Snames is
Name_GPL : constant Name_Id := N + $;
Name_IEEE_Float : constant Name_Id := N + $;
Name_Ignore : constant Name_Id := N + $;
Name_Increases : constant Name_Id := N + $;
Name_Increasing : constant Name_Id := N + $;
Name_Info : constant Name_Id := N + $;
Name_Internal : constant Name_Id := N + $;
Name_Link_Name : constant Name_Id := N + $;
......@@ -753,6 +753,7 @@ package Snames is
Name_Unrestricted : constant Name_Id := N + $;
Name_Uppercase : constant Name_Id := N + $;
Name_User : constant Name_Id := N + $;
Name_Variant : constant Name_Id := N + $;
Name_VAX_Float : constant Name_Id := N + $;
Name_VMS : constant Name_Id := N + $;
Name_Vtable_Ptr : constant Name_Id := N + $;
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment