+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.
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
-- 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 --
---------------------
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);
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
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
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
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
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
-- 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.
-- 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
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;
-----------------------------
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;
------------------------------
(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;
------------------------
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;
----------------------------
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 --
-----------------------
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;
------------------
-- 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))
-- 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;
-- 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;
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;
---------------------------
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;
----------------------------------
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;
---------------------------
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;
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;
-----------------
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;
-----------------------
-- 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,
projects / gcc.git / commitdiff