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 256 additions and 100 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> 2012-11-06 Robert Dewar <dewar@adacore.com>
* exp_prag.adb, impunit.adb, exp_ch9.adb, par-ch4.adb, * 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 ...@@ -807,8 +807,8 @@ package body Exp_Prag is
-- <preceding source statements> -- <preceding source statements>
-- pragma Loop_Assertion -- pragma Loop_Assertion
-- (Invariant => Invar_Expr, -- (Invariant => Invar_Expr,
-- Increases => Incr_Expr, -- Variant => (Increasing => Incr_Expr,
-- Decreases => Decr_Expr); -- Decreasing => Decr_Expr));
-- <succeeding source statements> -- <succeeding source statements>
-- end loop; -- end loop;
...@@ -855,15 +855,20 @@ package body Exp_Prag is ...@@ -855,15 +855,20 @@ package body Exp_Prag is
Loop_Stmt : Node_Id; Loop_Stmt : Node_Id;
Old_Assign : List_Id := No_List; Old_Assign : List_Id := No_List;
procedure Process_Increase_Decrease (Arg : Node_Id; Is_Last : Boolean); procedure Process_Increase_Decrease
-- Process a single increases/decreases expression. Flag Is_Last should (Variant : Node_Id;
-- be set when the expression is the last argument to be processed. Is_Last : Boolean);
-- Process a single increasing / decreasing termination variant. Flag
-- Is_Last should be set when processing the last variant.
------------------------------- -------------------------------
-- Process_Increase_Decrease -- -- 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 function Make_Op
(Loc : Source_Ptr; (Loc : Source_Ptr;
Curr_Val : Node_Id; Curr_Val : Node_Id;
...@@ -880,26 +885,21 @@ package body Exp_Prag is ...@@ -880,26 +885,21 @@ package body Exp_Prag is
Curr_Val : Node_Id; Curr_Val : Node_Id;
Old_Val : Node_Id) return Node_Id Old_Val : Node_Id) return Node_Id
is is
Modif : constant Node_Id := First (Choices (Variant));
begin begin
if Chars (Arg) = Name_Increases then if Chars (Modif) = Name_Increasing then
return return Make_Op_Gt (Loc, Curr_Val, Old_Val);
Make_Op_Gt (Loc,
Left_Opnd => Curr_Val, else pragma Assert (Chars (Modif) = Name_Decreasing);
Right_Opnd => Old_Val); return Make_Op_Lt (Loc, Curr_Val, Old_Val);
else pragma Assert (Chars (Arg) = Name_Decreases);
return
Make_Op_Lt (Loc,
Left_Opnd => Curr_Val,
Right_Opnd => Old_Val);
end if; end if;
end Make_Op; end Make_Op;
-- Local variables -- 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); Loop_Loc : constant Source_Ptr := Sloc (Loop_Stmt);
Cond : Node_Id;
Curr_Id : Entity_Id; Curr_Id : Entity_Id;
Old_Id : Entity_Id; Old_Id : Entity_Id;
Prag : Node_Id; Prag : Node_Id;
...@@ -909,7 +909,8 @@ package body Exp_Prag is ...@@ -909,7 +909,8 @@ package body Exp_Prag is
begin begin
-- All temporaries generated in this routine must be inserted before -- All temporaries generated in this routine must be inserted before
-- the related loop statement. Ensure that the proper scope is on the -- 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)); Push_Scope (Scope (Loop_Scop));
...@@ -930,6 +931,21 @@ package body Exp_Prag is ...@@ -930,6 +931,21 @@ package body Exp_Prag is
New_Reference_To (Standard_Boolean, Loop_Loc), New_Reference_To (Standard_Boolean, Loop_Loc),
Expression => Expression =>
New_Reference_To (Standard_False, Loop_Loc))); 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; end if;
-- Step 2: Create the temporaries which store the old and current -- Step 2: Create the temporaries which store the old and current
...@@ -1008,16 +1024,22 @@ package body Exp_Prag is ...@@ -1008,16 +1024,22 @@ package body Exp_Prag is
-- if Curr /= Old then -- if Curr /= Old then
-- <Prag>; -- <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 if No (If_Stmt) then
If_Stmt :=
Make_If_Statement (Loc, -- When there is just one termination variant, do not compare the
Condition => Cond, -- old and current value for equality, just check the pragma.
Then_Statements => New_List (Prag));
if Is_Last then
If_Stmt := Prag;
else
If_Stmt :=
Make_If_Statement (Loc,
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: -- Generate:
-- else -- else
...@@ -1038,31 +1060,24 @@ package body Exp_Prag is ...@@ -1038,31 +1060,24 @@ package body Exp_Prag is
Append_To (Elsif_Parts (If_Stmt), Append_To (Elsif_Parts (If_Stmt),
Make_Elsif_Part (Loc, 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))); Then_Statements => New_List (Prag)));
end if; end if;
end Process_Increase_Decrease; end Process_Increase_Decrease;
-- Local variables -- Local variables
Args : constant List_Id := Pragma_Argument_Associations (N); Arg : Node_Id;
Last_Arg : constant Node_Id := Last (Args); Invar : Node_Id := Empty;
Arg : Node_Id;
Invar : Node_Id := Empty;
-- Start of processing for Expand_Pragma_Loop_Assertion -- Start of processing for Expand_Pragma_Loop_Assertion
begin begin
-- Locate the enclosing loop for which this assertion applies -- 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; Loop_Stmt := N;
while Present (Loop_Stmt) while Present (Loop_Stmt)
and then Nkind (Loop_Stmt) /= N_Loop_Statement and then Nkind (Loop_Stmt) /= N_Loop_Statement
...@@ -1070,14 +1085,35 @@ package body Exp_Prag is ...@@ -1070,14 +1085,35 @@ package body Exp_Prag is
Loop_Stmt := Parent (Loop_Stmt); Loop_Stmt := Parent (Loop_Stmt);
end loop; end loop;
Loop_Scop := Entity (Identifier (Loop_Stmt));
-- Process all pragma arguments -- Process all pragma arguments
Arg := First (Args); Arg := First (Pragma_Argument_Associations (N));
while Present (Arg) loop while Present (Arg) loop
if Chars (Arg) = Name_Increases
or else Chars (Arg) = Name_Decreases -- Termination variants appear as components in an aggregate
then
Process_Increase_Decrease (Arg, Is_Last => Arg = Last_Arg); 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 else
Invar := Expression (Arg); Invar := Expression (Arg);
end if; end if;
...@@ -1088,13 +1124,19 @@ package body Exp_Prag is ...@@ -1088,13 +1124,19 @@ package body Exp_Prag is
-- Verify the invariant expression, generate: -- Verify the invariant expression, generate:
-- pragma Assert (<Invar>); -- pragma Assert (<Invar>);
-- Use the Sloc of the invariant for better error reporting
if Present (Invar) then if Present (Invar) then
Insert_Action (N, declare
Make_Pragma (Loc, Invar_Loc : constant Source_Ptr := Sloc (Invar);
Chars => Name_Assert, begin
Pragma_Argument_Associations => New_List ( Insert_Action (N,
Make_Pragma_Argument_Association (Loc, Make_Pragma (Invar_Loc,
Expression => Relocate_Node (Invar))))); Chars => Name_Assert,
Pragma_Argument_Associations => New_List (
Make_Pragma_Argument_Association (Invar_Loc,
Expression => Relocate_Node (Invar)))));
end;
end if; end if;
-- Construct the segment which stores the old values of all expressions. -- Construct the segment which stores the old values of all expressions.
...@@ -1135,7 +1177,8 @@ package body Exp_Prag is ...@@ -1135,7 +1177,8 @@ package body Exp_Prag is
Expression => New_Reference_To (Standard_True, Loc))))); Expression => New_Reference_To (Standard_True, Loc)))));
end if; 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)); Rewrite (N, Make_Null_Statement (Loc));
Analyze (N); Analyze (N);
......
gcc/ada/sem_eval.adb
...@@ -1759,21 +1759,63 @@ package body Sem_Eval is ...@@ -1759,21 +1759,63 @@ package body Sem_Eval is
-- Eval_Case_Expression -- -- Eval_Case_Expression --
-------------------------- --------------------------
-- Right now we do not attempt folding of any case expressions, and the -- A conditional expression is static if all its conditions and dependent
-- language does not require it, so the only required processing is to -- expressions are static.
-- do the check for all expressions appearing in the case expression.
procedure Eval_Case_Expression (N : Node_Id) is procedure Eval_Case_Expression (N : Node_Id) is
Alt : Node_Id; Alt : Node_Id;
Choice : Node_Id;
Is_Static : Boolean;
Result : Node_Id;
Val : Uint;
begin begin
Check_Non_Static_Context (Expression (N)); 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)); Alt := First (Alternatives (N));
while Present (Alt) loop
Check_Non_Static_Context (Expression (Alt)); Search : while Present (Alt) loop
if not Is_Static
or else not Is_Static_Expression (Expression (Alt))
then
Check_Non_Static_Context (Expression (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); Next (Alt);
end loop; 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; end Eval_Case_Expression;
------------------------ ------------------------
......
gcc/ada/sem_prag.adb
...@@ -11288,18 +11288,71 @@ package body Sem_Prag is ...@@ -11288,18 +11288,71 @@ package body Sem_Prag is
-- Loop_Assertion -- -- Loop_Assertion --
-------------------- --------------------
-- pragma Loop_Assertion ( -- pragma Loop_Assertion
-- [[Invariant =>] boolean_EXPRESSION], -- ( [Invariant =>] boolean_Expression
-- {CHANGE_MODE => discrete_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 when Pragma_Loop_Assertion => Loop_Assertion : declare
Arg : Node_Id; procedure Check_Variant (Arg : Node_Id);
Expr : Node_Id; -- Verify the legality of a variant
Seen : Boolean := False;
-------------------
-- 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; Stmt : Node_Id;
-- Start of processing for Loop_Assertion
begin begin
GNAT_Pragma; GNAT_Pragma;
S14_Pragma; S14_Pragma;
...@@ -11324,46 +11377,43 @@ package body Sem_Prag is ...@@ -11324,46 +11377,43 @@ package body Sem_Prag is
end if; end if;
Check_At_Least_N_Arguments (1); Check_At_Least_N_Arguments (1);
Check_At_Most_N_Arguments (2);
-- Process the arguments -- Process the first argument
Arg := Arg1; if Chars (Arg1) = Name_Variant then
while Present (Arg) loop Check_Variant (Arg1);
Expr := Expression (Arg);
-- All expressions are preanalyzed because they will be elsif Chars (Arg1) = No_Name
-- relocated during expansion and analyzed in their new or else Chars (Arg1) = Name_Invariant
-- context. then
Preanalyze_And_Resolve (Expression (Arg1), Any_Boolean);
if Chars (Arg) = Name_Invariant else
or else Error_Pragma_Arg ("argument not allowed in pragma %", Arg1);
(Arg_Count = 1 end if;
and then Chars (Arg) /= Name_Increases
and then Chars (Arg) /= Name_Decreases)
then
-- Only one invariant is allowed in the pragma
if Seen then -- Process the second argument
Error_Pragma_Arg
("only one invariant allowed in pragma %", Arg); 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 else
Seen := True; Check_Variant (Arg2);
Preanalyze_And_Resolve (Expr, Any_Boolean);
end if; end if;
elsif Chars (Arg) = Name_Increases elsif Chars (Arg2) = Name_Invariant then
or else Chars (Arg) = Name_Decreases if Chars (Arg1) = Name_Variant then
then Error_Pragma_Arg ("invariant must precede variant", Arg2);
Preanalyze_And_Resolve (Expr, Any_Discrete); else
Error_Pragma ("only one invariant allowed in pragma %");
-- Illegal argument end if;
else else
Error_Pragma_Arg ("argument not allowed in pragma %", Arg); Error_Pragma_Arg ("argument not allowed in pragma %", Arg2);
end if; end if;
end if;
Next (Arg);
end loop;
end Loop_Assertion; end Loop_Assertion;
----------------------- -----------------------
......
gcc/ada/snames.ads-tmpl
...@@ -671,7 +671,7 @@ package Snames is ...@@ -671,7 +671,7 @@ package Snames is
Name_Component_Size_4 : constant Name_Id := N + $; Name_Component_Size_4 : constant Name_Id := N + $;
Name_Copy : constant Name_Id := N + $; Name_Copy : constant Name_Id := N + $;
Name_D_Float : 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_Descriptor : constant Name_Id := N + $;
Name_Disable : constant Name_Id := N + $; Name_Disable : constant Name_Id := N + $;
Name_Dot_Replacement : constant Name_Id := N + $; Name_Dot_Replacement : constant Name_Id := N + $;
...@@ -691,7 +691,7 @@ package Snames is ...@@ -691,7 +691,7 @@ package Snames is
Name_GPL : constant Name_Id := N + $; Name_GPL : constant Name_Id := N + $;
Name_IEEE_Float : constant Name_Id := N + $; Name_IEEE_Float : constant Name_Id := N + $;
Name_Ignore : 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_Info : constant Name_Id := N + $;
Name_Internal : constant Name_Id := N + $; Name_Internal : constant Name_Id := N + $;
Name_Link_Name : constant Name_Id := N + $; Name_Link_Name : constant Name_Id := N + $;
...@@ -753,6 +753,7 @@ package Snames is ...@@ -753,6 +753,7 @@ package Snames is
Name_Unrestricted : constant Name_Id := N + $; Name_Unrestricted : constant Name_Id := N + $;
Name_Uppercase : constant Name_Id := N + $; Name_Uppercase : constant Name_Id := N + $;
Name_User : constant Name_Id := N + $; Name_User : constant Name_Id := N + $;
Name_Variant : constant Name_Id := N + $;
Name_VAX_Float : constant Name_Id := N + $; Name_VAX_Float : constant Name_Id := N + $;
Name_VMS : constant Name_Id := N + $; Name_VMS : constant Name_Id := N + $;
Name_Vtable_Ptr : 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