Skip to content

R
riscv-gcc-1
Commit 22e89283 by Arnaud Charlet
Options

[multiple changes] 

2015-05-26  Javier Miranda  <miranda@adacore.com>

	* sem_aggr.adb (Resolve_Aggregate, Resolve_Extension_Aggregate):
	Code cleanup.
	* sem_ch3.adb (Build_Derived_Record_Type,
	Record_Type_Declaration): Code cleanup.
	* sem_ch4.adb (Has_Arbitrary_Evaluation_Order,
	Stop_Subtree_Climbind): Tables which speed up the identification
	of dangerous calls to Ada 2012 functions with writable actuals
	(AI05-0144).
	(Analyze_Arithmetic_Op, Analyze_Call, Analyze_Comparison_Op,
	Analyze_Equality_Op, Analyze_Logical_Op, Analyze_Membership_Op,
	Analyze_Range): Code cleanup.
	(Is_Arbitrary_Evaluation_Order_Construct): Removed.
	(Check_Writable_Actuals): Code cleanup using the added tables.
	* sem_util.adb (Check_Function_Writable_Actuals): Return
	immediately if the node does not have the flag Check_Actuals
	set to True.

2015-05-26  Eric Botcazou  <ebotcazou@adacore.com>

	* exp_ch6.adb (Add_Call_By_Copy_Code): Remove restrictive
	condition in the detection of the effects of Remove_Side_Effects.
	* exp_util.ads (Remove_Side_Effects): Add general and historical note.
	* exp_util.adb (Is_Name_Reference): New predicate.
	(Remove_Side_Effects): Use it in lieu of Is_Object_Reference
	in order to decide whether to use the renaming to capture the
	side effects of the subexpression.
	(Side_Effect_Free): Remove obsolete test.

From-SVN: r223668
parent c8593453
Showing with 268 additions and 172 deletions
gcc/ada/ChangeLog
2015-05-26 Javier Miranda <miranda@adacore.com>
* sem_aggr.adb (Resolve_Aggregate, Resolve_Extension_Aggregate):
Code cleanup.
* sem_ch3.adb (Build_Derived_Record_Type,
Record_Type_Declaration): Code cleanup.
* sem_ch4.adb (Has_Arbitrary_Evaluation_Order,
Stop_Subtree_Climbind): Tables which speed up the identification
of dangerous calls to Ada 2012 functions with writable actuals
(AI05-0144).
(Analyze_Arithmetic_Op, Analyze_Call, Analyze_Comparison_Op,
Analyze_Equality_Op, Analyze_Logical_Op, Analyze_Membership_Op,
Analyze_Range): Code cleanup.
(Is_Arbitrary_Evaluation_Order_Construct): Removed.
(Check_Writable_Actuals): Code cleanup using the added tables.
* sem_util.adb (Check_Function_Writable_Actuals): Return
immediately if the node does not have the flag Check_Actuals
set to True.
2015-05-26 Eric Botcazou <ebotcazou@adacore.com>
* exp_ch6.adb (Add_Call_By_Copy_Code): Remove restrictive
condition in the detection of the effects of Remove_Side_Effects.
* exp_util.ads (Remove_Side_Effects): Add general and historical note.
* exp_util.adb (Is_Name_Reference): New predicate.
(Remove_Side_Effects): Use it in lieu of Is_Object_Reference
in order to decide whether to use the renaming to capture the
side effects of the subexpression.
(Side_Effect_Free): Remove obsolete test.
2015-05-26 Robert Dewar <dewar@adacore.com>
* aspects.ads, aspects.adb: Add aspect Disable_Controlled.
......
gcc/ada/exp_ch6.adb
......@@ -1257,7 +1257,6 @@ package body Exp_Ch6 is
begin
if Is_Renaming_Of_Object (Var)
and then Nkind (Renamed_Object (Var)) = N_Selected_Component
and then Is_Entity_Name (Prefix (Renamed_Object (Var)))
and then Nkind (Original_Node (Prefix (Renamed_Object (Var))))
= N_Indexed_Component
and then
......
gcc/ada/exp_util.adb
......@@ -7428,6 +7428,12 @@ package body Exp_Util is
-- is present (xxx is taken from the Chars field of Related_Nod),
-- otherwise it generates an internal temporary.
function Is_Name_Reference (N : Node_Id) return Boolean;
-- Determine if the tree referenced by N represents a name. This is
-- similar to Is_Object_Reference but returns true only if N can be
-- renamed without the need for a temporary, the typical example of
-- an object not in this category being a function call.
---------------------
-- Build_Temporary --
---------------------
......@@ -7458,6 +7464,58 @@ package body Exp_Util is
end if;
end Build_Temporary;
-----------------------
-- Is_Name_Reference --
-----------------------
function Is_Name_Reference (N : Node_Id) return Boolean is
begin
if Is_Entity_Name (N) then
return Present (Entity (N)) and then Is_Object (Entity (N));
end if;
case Nkind (N) is
when N_Indexed_Component | N_Slice =>
return
Is_Name_Reference (Prefix (N))
or else Is_Access_Type (Etype (Prefix (N)));
-- Attributes 'Input, 'Old and 'Result produce objects
when N_Attribute_Reference =>
return
Nam_In
(Attribute_Name (N), Name_Input, Name_Old, Name_Result);
when N_Selected_Component =>
return
Is_Name_Reference (Selector_Name (N))
and then
(Is_Name_Reference (Prefix (N))
or else Is_Access_Type (Etype (Prefix (N))));
when N_Explicit_Dereference =>
return True;
-- A view conversion of a tagged name is a name reference
when N_Type_Conversion =>
return Is_Tagged_Type (Etype (Subtype_Mark (N)))
and then Is_Tagged_Type (Etype (Expression (N)))
and then Is_Name_Reference (Expression (N));
-- An unchecked type conversion is considered to be a name if
-- the operand is a name (this construction arises only as a
-- result of expansion activities).
when N_Unchecked_Type_Conversion =>
return Is_Name_Reference (Expression (N));
when others =>
return False;
end case;
end Is_Name_Reference;
-- Local variables
Loc : constant Source_Ptr := Sloc (Exp);
......@@ -7498,34 +7556,25 @@ package body Exp_Util is
return;
end if;
-- The remaining procesaing is done with all checks suppressed
-- The remaining processing is done with all checks suppressed
-- Note: from now on, don't use return statements, instead do a goto
-- Leave, to ensure that we properly restore Scope_Suppress.Suppress.
Scope_Suppress.Suppress := (others => True);
-- If it is a scalar type and we need to capture the value, just make
-- a copy. Likewise for a function call, an attribute reference, a
-- conditional expression, an allocator, or an operator. And if we have
-- a volatile reference and Name_Req is not set (see comments for
-- Side_Effect_Free).
-- If it is an elementary type and we need to capture the value, just
-- make a constant. Likewise if this is not a name reference, except
-- for a type conversion because we would enter an infinite recursion
-- with Checks.Apply_Predicate_Check if the target type has predicates.
-- And type conversions need a specific treatment anyway, see below.
-- Also do it if we have a volatile reference and Name_Req is not set
-- (see comments for Side_Effect_Free).
if Is_Elementary_Type (Exp_Type)
-- Note: this test is rather mysterious??? Why can't we just test ONLY
-- Is_Elementary_Type and be done with it. If we try that approach, we
-- get some failures (infinite recursions) from the Duplicate_Subexpr
-- call at the end of Checks.Apply_Predicate_Check. To be
-- investigated ???
and then (Variable_Ref
or else Nkind_In (Exp, N_Attribute_Reference,
N_Allocator,
N_Case_Expression,
N_If_Expression,
N_Function_Call)
or else Nkind (Exp) in N_Op
or else (not Is_Name_Reference (Exp)
and then Nkind (Exp) /= N_Type_Conversion)
or else (not Name_Req
and then Is_Volatile_Reference (Exp)))
then
......@@ -7645,20 +7694,13 @@ package body Exp_Util is
Insert_Action (Exp, E);
end if;
-- For expressions that denote objects, we can use a renaming scheme.
-- For expressions that denote names, we can use a renaming scheme.
-- This is needed for correctness in the case of a volatile object of
-- a non-volatile type because the Make_Reference call of the "default"
-- approach would generate an illegal access value (an access value
-- cannot designate such an object - see Analyze_Reference).
elsif Is_Object_Reference (Exp)
and then Nkind (Exp) /= N_Function_Call
-- In Ada 2012 a qualified expression is an object, but for purposes
-- of removing side effects it still need to be transformed into a
-- separate declaration, particularly in the case of an aggregate.
and then Nkind (Exp) /= N_Qualified_Expression
elsif Is_Name_Reference (Exp)
-- We skip using this scheme if we have an object of a volatile
-- type and we do not have Name_Req set true (see comments for
......@@ -7667,37 +7709,13 @@ package body Exp_Util is
and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
then
Def_Id := Build_Temporary (Loc, 'R', Exp);
Res := New_Occurrence_Of (Def_Id, Loc);
if Nkind (Exp) = N_Selected_Component
and then Nkind (Prefix (Exp)) = N_Function_Call
and then Is_Array_Type (Exp_Type)
then
-- Avoid generating a variable-sized temporary, by generating
-- the renaming declaration just for the function call. The
-- transformation could be refined to apply only when the array
-- component is constrained by a discriminant???
Res :=
Make_Selected_Component (Loc,
Prefix => New_Occurrence_Of (Def_Id, Loc),
Selector_Name => Selector_Name (Exp));
Insert_Action (Exp,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Def_Id,
Subtype_Mark =>
New_Occurrence_Of (Base_Type (Etype (Prefix (Exp))), Loc),
Name => Relocate_Node (Prefix (Exp))));
else
Res := New_Occurrence_Of (Def_Id, Loc);
Insert_Action (Exp,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Def_Id,
Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
Name => Relocate_Node (Exp)));
end if;
Insert_Action (Exp,
Make_Object_Renaming_Declaration (Loc,
Defining_Identifier => Def_Id,
Subtype_Mark => New_Occurrence_Of (Exp_Type, Loc),
Name => Relocate_Node (Exp)));
-- If this is a packed reference, or a selected component with
-- a non-standard representation, a reference to the temporary
......@@ -7715,7 +7733,19 @@ package body Exp_Util is
Set_Is_Renaming_Of_Object (Def_Id, False);
end if;
-- Otherwise we generate a reference to the value
-- Avoid generating a variable-sized temporary, by generating the
-- reference just for the function call. The transformation could be
-- refined to apply only when the array component is constrained by a
-- discriminant???
elsif Nkind (Exp) = N_Selected_Component
and then Nkind (Prefix (Exp)) = N_Function_Call
and then Is_Array_Type (Exp_Type)
then
Remove_Side_Effects (Prefix (Exp), Name_Req, Variable_Ref);
goto Leave;
-- Otherwise we generate a reference to the expression
else
-- An expression which is in SPARK mode is considered side effect
......@@ -8974,23 +9004,10 @@ package body Exp_Util is
return Side_Effect_Free (Expression (N), Name_Req, Variable_Ref);
-- A selected component is side effect free only if it is a side
-- effect free prefixed reference. If it designates a component
-- with a rep. clause it must be treated has having a potential
-- side effect, because it may be modified through a renaming, and
-- a subsequent use of the renaming as a macro will yield the
-- wrong value. This complex interaction between renaming and
-- removing side effects is a reminder that the latter has become
-- a headache to maintain, and that it should be removed in favor
-- of the gcc mechanism to capture values ???
-- effect free prefixed reference.
when N_Selected_Component =>
if Nkind (Parent (N)) = N_Explicit_Dereference
and then Has_Non_Standard_Rep (Designated_Type (Typ))
then
return False;
else
return Safe_Prefixed_Reference (N);
end if;
return Safe_Prefixed_Reference (N);
-- A range is side effect free if the bounds are side effect free
......
gcc/ada/exp_util.ads
......@@ -872,8 +872,8 @@ package Exp_Util is
-- call and is analyzed and resolved on return. Name_Req may only be set to
-- True if Exp has the form of a name, and the effect is to guarantee that
-- any replacement maintains the form of name. If Renaming_Req is set to
-- TRUE, the routine produces an object renaming reclaration capturing the
-- expression. If Variable_Ref is set to TRUE, a variable is considered as
-- True, the routine produces an object renaming reclaration capturing the
-- expression. If Variable_Ref is set to True, a variable is considered as
-- side effect (used in implementing Force_Evaluation). Note: after call to
-- Remove_Side_Effects, it is safe to call New_Copy_Tree to obtain a copy
-- of the resulting expression.
......@@ -885,6 +885,26 @@ package Exp_Util is
-- Chars (Related_Id)_FIRST/_LAST. If Related_Id is set, then exactly one
-- of the Is_xxx_Bound flags must be set. For use of these parameters see
-- the warning in the body of Sem_Ch3.Process_Range_Expr_In_Decl.
--
-- The side effects are captured using one of the following methods:
--
-- 1) a constant initialized with the value of the subexpression
-- 2) a renaming of the subexpression
-- 3) a reference to the subexpression
--
-- For elementary types, methods 1) and 2) are used; for composite types,
-- methods 2) and 3) are used. The renaming (method 2) is used only when
-- the subexpression denotes a name, so that it can be elaborated by gigi
-- without evaluating the subexpression.
--
-- Historical note: the reference (method 3) used to be the common fallback
-- method but it gives rise to aliasing issues if the subexpression denotes
-- a name that is not aliased, since it is equivalent to taking the address
-- in this case. The renaming (method 2) used to be applied to any objects
-- in the RM sense, that is to say to the cases where a renaming is legal
-- in Ada. But for some of these cases, most notably functions calls, the
-- renaming cannot be elaborated without evaluating the subexpression, so
-- gigi would resort to method 1) or 3) under the hood for them.
function Represented_As_Scalar (T : Entity_Id) return Boolean;
-- Returns True iff the implementation of this type in code generation
......
gcc/ada/sem_aggr.adb
......@@ -1161,9 +1161,7 @@ package body Sem_Aggr is
Set_Analyzed (N);
end if;
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
end Resolve_Aggregate;
-----------------------------
......@@ -2906,9 +2904,7 @@ package body Sem_Aggr is
Error_Msg_N ("no unique type for this aggregate", A);
end if;
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
end Resolve_Extension_Aggregate;
------------------------------
......
gcc/ada/sem_ch3.adb
......@@ -8955,9 +8955,7 @@ package body Sem_Ch3 is
(Class_Wide_Type (Derived_Type), Last_Entity (Derived_Type));
end if;
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
end Build_Derived_Record_Type;
------------------------
......@@ -21122,9 +21120,7 @@ package body Sem_Ch3 is
Derive_Progenitor_Subprograms (T, T);
end if;
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
end Record_Type_Declaration;
----------------------------
......
gcc/ada/sem_ch4.adb
......@@ -65,6 +65,110 @@ with Uintp; use Uintp;
package body Sem_Ch4 is
-- Tables which speed up the identification of dangerous calls to Ada 2012
-- functions with writable actuals (AI05-0144).
-- The following table enumerates the Ada constructs which may evaluate in
-- arbitrary order. It does not cover all the language constructs which can
-- be evaluated in arbitrary order but the subset needed for AI05-0144.
Has_Arbitrary_Evaluation_Order : constant array (Node_Kind) of Boolean :=
(N_Aggregate => True,
N_Assignment_Statement => True,
N_Entry_Call_Statement => True,
N_Extension_Aggregate => True,
N_Full_Type_Declaration => True,
N_Indexed_Component => True,
N_Object_Declaration => True,
N_Pragma => True,
N_Range => True,
N_Slice => True,
-- N_Array_Type_Definition
-- why not
-- N_Array_Type_Definition => True,
-- etc ???
N_Constrained_Array_Definition => True,
N_Unconstrained_Array_Definition => True,
-- N_Membership_Test
N_In => True,
N_Not_In => True,
-- N_Binary_Op
N_Op_Add => True,
N_Op_Concat => True,
N_Op_Expon => True,
N_Op_Subtract => True,
N_Op_Divide => True,
N_Op_Mod => True,
N_Op_Multiply => True,
N_Op_Rem => True,
N_Op_And => True,
N_Op_Eq => True,
N_Op_Ge => True,
N_Op_Gt => True,
N_Op_Le => True,
N_Op_Lt => True,
N_Op_Ne => True,
N_Op_Or => True,
N_Op_Xor => True,
N_Op_Rotate_Left => True,
N_Op_Rotate_Right => True,
N_Op_Shift_Left => True,
N_Op_Shift_Right => True,
N_Op_Shift_Right_Arithmetic => True,
N_Op_Not => True,
N_Op_Plus => True,
-- N_Subprogram_Call
N_Function_Call => True,
N_Procedure_Call_Statement => True,
others => False);
-- The following table enumerates the nodes on which we stop climbing when
-- locating the outermost Ada construct that can be evaluated in arbitrary
-- order.
Stop_Subtree_Climbing : constant array (Node_Kind) of Boolean :=
(N_Aggregate => True,
N_Assignment_Statement => True,
N_Entry_Call_Statement => True,
N_Extended_Return_Statement => True,
N_Extension_Aggregate => True,
N_Full_Type_Declaration => True,
N_Object_Declaration => True,
N_Object_Renaming_Declaration => True,
N_Package_Specification => True,
N_Pragma => True,
N_Procedure_Call_Statement => True,
N_Simple_Return_Statement => True,
-- N_Has_Condition
N_Exit_Statement => True,
N_If_Statement => True,
N_Accept_Alternative => True,
N_Delay_Alternative => True,
N_Elsif_Part => True,
N_Entry_Body_Formal_Part => True,
N_Iteration_Scheme => True,
others => False);
-----------------------
-- Local Subprograms --
-----------------------
......@@ -830,10 +934,7 @@ package body Sem_Ch4 is
end if;
Operator_Check (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
end Analyze_Arithmetic_Op;
------------------
......@@ -945,40 +1046,6 @@ package body Sem_Ch4 is
-- enabled.
procedure Check_Writable_Actuals (N : Node_Id) is
function Is_Arbitrary_Evaluation_Order_Construct
(N : Node_Id) return Boolean;
-- Return True if N is an Ada construct which may be evaluated in
-- an arbitrary order. This function does not cover all the language
-- constructs that can be evaluated in arbitrary order, but only the
-- subset needed for AI05-0144.
---------------------------------------------
-- Is_Arbitrary_Evaluation_Order_Construct --
---------------------------------------------
function Is_Arbitrary_Evaluation_Order_Construct
(N : Node_Id) return Boolean is
begin
return Nkind (N) = N_Aggregate
or else Nkind (N) = N_Assignment_Statement
or else Nkind (N) = N_Full_Type_Declaration
or else Nkind (N) = N_Entry_Call_Statement
or else Nkind (N) = N_Extension_Aggregate
or else Nkind (N) = N_Indexed_Component
or else Nkind (N) = N_Object_Declaration
or else Nkind (N) = N_Pragma
or else Nkind (N) = N_Range
or else Nkind (N) = N_Slice
or else Nkind (N) in N_Array_Type_Definition
or else Nkind (N) in N_Membership_Test
or else Nkind (N) in N_Op
or else Nkind (N) in N_Subprogram_Call;
end Is_Arbitrary_Evaluation_Order_Construct;
-- Start of processing for Check_Writable_Actuals
begin
if Comes_From_Source (N)
and then Present (Get_Subprogram_Entity (N))
......@@ -1010,31 +1077,19 @@ package body Sem_Ch4 is
-- to the routine that will later take care of
-- performing the writable actuals check.
if Is_Arbitrary_Evaluation_Order_Construct (P)
and then Nkind (P) /= N_Assignment_Statement
and then Nkind (P) /= N_Object_Declaration
if Has_Arbitrary_Evaluation_Order (Nkind (P))
and then not Nkind_In (P, N_Assignment_Statement,
N_Object_Declaration)
then
Outermost := P;
end if;
-- Avoid climbing more than needed!
exit when Nkind (P) = N_Aggregate
or else Nkind (P) = N_Assignment_Statement
or else Nkind (P) = N_Entry_Call_Statement
or else Nkind (P) = N_Extended_Return_Statement
or else Nkind (P) = N_Extension_Aggregate
or else Nkind (P) = N_Full_Type_Declaration
or else Nkind (P) = N_Object_Declaration
or else Nkind (P) = N_Object_Renaming_Declaration
or else Nkind (P) = N_Package_Specification
or else Nkind (P) = N_Pragma
or else Nkind (P) = N_Procedure_Call_Statement
or else Nkind (P) = N_Simple_Return_Statement
exit when Stop_Subtree_Climbing (Nkind (P))
or else (Nkind (P) = N_Range
and then not
Nkind_In (Parent (P), N_In, N_Not_In))
or else Nkind (P) in N_Has_Condition;
Nkind_In (Parent (P), N_In, N_Not_In));
P := Parent (P);
end loop;
......@@ -1411,9 +1466,7 @@ package body Sem_Ch4 is
-- an arbitrary order is precisely this call, then check all its
-- actuals.
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
end if;
end Analyze_Call;
......@@ -1632,10 +1685,7 @@ package body Sem_Ch4 is
end if;
Operator_Check (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
end Analyze_Comparison_Op;
---------------------------
......@@ -1883,10 +1933,7 @@ package body Sem_Ch4 is
end if;
Operator_Check (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
end Analyze_Equality_Op;
----------------------------------
......@@ -2710,10 +2757,7 @@ package body Sem_Ch4 is
end if;
Operator_Check (N);
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
end Analyze_Logical_Op;
---------------------------
......@@ -2869,10 +2913,7 @@ package body Sem_Ch4 is
if No (R) and then Ada_Version >= Ada_2012 then
Analyze_Set_Membership;
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
return;
end if;
......@@ -2946,9 +2987,7 @@ package body Sem_Ch4 is
Error_Msg_N ("membership test not applicable to cpp-class types", N);
end if;
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
end Analyze_Membership_Op;
-----------------
......@@ -4028,9 +4067,7 @@ package body Sem_Ch4 is
Check_Universal_Expression (H);
end if;
if Check_Actuals (N) then
Check_Function_Writable_Actuals (N);
end if;
Check_Function_Writable_Actuals (N);
end Analyze_Range;
-----------------------
......
gcc/ada/sem_util.adb
......@@ -2324,11 +2324,12 @@ package body Sem_Util is
-- Start of processing for Check_Function_Writable_Actuals
begin
-- The check only applies to Ada 2012 code, and only to constructs that
-- have multiple constituents whose order of evaluation is not specified
-- by the language.
-- The check only applies to Ada 2012 code on which Check_Actuals has
-- been set, and only to constructs that have multiple constituents
-- whose order of evaluation is not specified by the language.
if Ada_Version < Ada_2012
or else not Check_Actuals (N)
or else (not (Nkind (N) in N_Op)
and then not (Nkind (N) in N_Membership_Test)
and then not Nkind_In (N, N_Range,
......
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