+2014-10-23 Hristian Kirtchev <kirtchev@adacore.com>
+
+ * checks.adb (Ensure_Valid): Update the subprogram
+ profile. Propagate the contex attributes to Insert_Valid_Check.
+ (Insert_Valid_Check): Update the subprogram profile. Propagate
+ the attributes of the context to Duplicate_Subexpr_No_Checks.
+ (Validity_Check_Range): Update the subprogram profile. Propagate
+ the context attribute to Ensure_Valid.
+ * checks.ads (Ensure_Valid): Update the subprogram profile
+ along with the comment on usage.
+ (Insert_Valid_Check): Update the subprogram profile along with the
+ comment on usage.
+ (Validity_Check_Range): Update the subprogram profile along with
+ the comment on usage.
+ * exp_util.adb (Build_Temporary): New routine.
+ (Duplicate_Subexpr_No_Checks): Update the subprogram
+ profile. Propagate the attributes of the context to Remove_Side_Effects.
+ (Remove_Side_Effects): Update the subprogram profile. Update all calls
+ to Make_Temporary to invoke Build_Temporary.
+ * exp_util.ads (Duplicate_Subexpr_No_Checks): Update
+ the subprogram profile along with the comment on usage.
+ (Remove_Side_Effects): Update the subprogram profile along with
+ the comment on usage.
+ * sem_ch3.adb (Process_Range_Expr_In_Decl): Pass the subtype
+ to the validity check machinery. Explain the reason for this
+ propagation.
+
+2014-10-23 Robert Dewar <dewar@adacore.com>
+
+ * a-strsea.adb: Minor reformatting.
+
2014-10-23 Thomas Quinot <quinot@adacore.com>
* bcheck.adb (Check_Consistent_SSO_Default): Exclude internal
First : out Positive;
Last : out Natural)
is
-
- -- RM 2005 A.4.3 (68/1)) specifies that an exception must be raised if
- -- Source'First is not positive and is assigned to First. Formulation
- -- is slightly different in RM 2012, but the intent seems similar, so
- -- we enable range checks for this routine.
-
- pragma Unsuppress (Range_Check);
-
begin
for J in Source'Range loop
if Belongs (Source (J), Set, Test) then
-- Here if no token found
- First := Source'First;
- Last := 0;
+ -- RM 2005 A.4.3 (68/1)) specifies that an exception must be raised if
+ -- Source'First is not positive and is assigned to First. Formulation
+ -- is slightly different in RM 2012, but the intent seems similar, so
+ -- we check explicitly for that condition.
+
+ if Source'First not in Positive then
+ raise Constraint_Error;
+
+ else
+ First := Source'First;
+ Last := 0;
+ end if;
end Find_Token;
-----------
-- Ensure_Valid --
------------------
- procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False) is
+ procedure Ensure_Valid
+ (Expr : Node_Id;
+ Holes_OK : Boolean := False;
+ Related_Id : Entity_Id := Empty;
+ Is_Low_Bound : Boolean := False;
+ Is_High_Bound : Boolean := False)
+ is
Typ : constant Entity_Id := Etype (Expr);
begin
-- If we fall through, a validity check is required
- Insert_Valid_Check (Expr);
+ Insert_Valid_Check (Expr, Related_Id, Is_Low_Bound, Is_High_Bound);
if Is_Entity_Name (Expr)
and then Safe_To_Capture_Value (Expr, Entity (Expr))
-- Insert_Valid_Check --
------------------------
- procedure Insert_Valid_Check (Expr : Node_Id) is
+ procedure Insert_Valid_Check
+ (Expr : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Is_Low_Bound : Boolean := False;
+ Is_High_Bound : Boolean := False)
+ is
Loc : constant Source_Ptr := Sloc (Expr);
Typ : constant Entity_Id := Etype (Expr);
Exp : Node_Id;
begin
- -- Do not insert if checks off, or if not checking validity or
- -- if expression is known to be valid
+ -- Do not insert if checks off, or if not checking validity or if
+ -- expression is known to be valid.
if not Validity_Checks_On
or else Range_Or_Validity_Checks_Suppressed (Expr)
-- Build the prefix for the 'Valid call
- PV := Duplicate_Subexpr_No_Checks (Exp, Name_Req => False);
+ PV :=
+ Duplicate_Subexpr_No_Checks
+ (Exp => Exp,
+ Name_Req => False,
+ Related_Id => Related_Id,
+ Is_Low_Bound => Is_Low_Bound,
+ Is_High_Bound => Is_High_Bound);
-- A rather specialized test. If PV is an analyzed expression which
-- is an indexed component of a packed array that has not been
-- a name, and we don't care in this context!
CE :=
- Make_Raise_Constraint_Error (Loc,
- Condition =>
- Make_Op_Not (Loc,
- Right_Opnd =>
- Make_Attribute_Reference (Loc,
- Prefix => PV,
- Attribute_Name => Name_Valid)),
- Reason => CE_Invalid_Data);
+ Make_Raise_Constraint_Error (Loc,
+ Condition =>
+ Make_Op_Not (Loc,
+ Right_Opnd =>
+ Make_Attribute_Reference (Loc,
+ Prefix => PV,
+ Attribute_Name => Name_Valid)),
+ Reason => CE_Invalid_Data);
-- Insert the validity check. Note that we do this with validity
-- checks turned off, to avoid recursion, we do not want validity
-- Validity_Check_Range --
--------------------------
- procedure Validity_Check_Range (N : Node_Id) is
+ procedure Validity_Check_Range
+ (N : Node_Id;
+ Related_Id : Entity_Id := Empty)
+ is
begin
if Validity_Checks_On and Validity_Check_Operands then
if Nkind (N) = N_Range then
- Ensure_Valid (Low_Bound (N));
- Ensure_Valid (High_Bound (N));
+ Ensure_Valid
+ (Expr => Low_Bound (N),
+ Related_Id => Related_Id,
+ Is_Low_Bound => True);
+
+ Ensure_Valid
+ (Expr => High_Bound (N),
+ Related_Id => Related_Id,
+ Is_High_Bound => True);
end if;
end if;
end Validity_Check_Range;
-- 13.9.1(9-11)) such assignments are not permitted to result in erroneous
-- behavior in the case of invalid subscript values.
- procedure Ensure_Valid (Expr : Node_Id; Holes_OK : Boolean := False);
+ procedure Ensure_Valid
+ (Expr : Node_Id;
+ Holes_OK : Boolean := False;
+ Related_Id : Entity_Id := Empty;
+ Is_Low_Bound : Boolean := False;
+ Is_High_Bound : Boolean := False);
-- Ensure that Expr represents a valid value of its type. If this type
-- is not a scalar type, then the call has no effect, since validity
-- is only an issue for scalar types. The effect of this call is to
-- will make a separate check for this case anyway). If Holes_OK is False,
-- then this case is checked, and code is inserted to ensure that Expr is
-- valid, raising Constraint_Error if the value is not valid.
+ --
+ -- Related_Id denotes the entity of the context where Expr appears. Flags
+ -- Is_Low_Bound and Is_High_Bound specify whether the expression to check
+ -- is the low or the high bound of a range. These three optional arguments
+ -- signal Remove_Side_Effects to create an external symbol of the form
+ -- Chars (Related_Id)_FIRST/_LAST.
function Expr_Known_Valid (Expr : Node_Id) return Boolean;
-- This function tests it the value of Expr is known to be valid in the
-- it can be determined that the value is Valid. Otherwise False is
-- returned.
- procedure Insert_Valid_Check (Expr : Node_Id);
- -- Inserts code that will check for the value of Expr being valid, in
- -- the sense of the 'Valid attribute returning True. Constraint_Error
- -- will be raised if the value is not valid.
+ procedure Insert_Valid_Check
+ (Expr : Node_Id;
+ Related_Id : Entity_Id := Empty;
+ Is_Low_Bound : Boolean := False;
+ Is_High_Bound : Boolean := False);
+ -- Inserts code that will check for the value of Expr being valid, in the
+ -- sense of the 'Valid attribute returning True. Constraint_Error will be
+ -- raised if the value is not valid.
+ --
+ -- Related_Id denotes the entity of the context where Expr appears. Flags
+ -- Is_Low_Bound and Is_High_Bound specify whether the expression to check
+ -- is the low or the high bound of a range. These three optional arguments
+ -- signal Remove_Side_Effects to create an external symbol of the form
+ -- Chars (Related_Id)_FIRST/_LAST.
procedure Null_Exclusion_Static_Checks (N : Node_Id);
-- Ada 2005 (AI-231): Check bad usages of the null-exclusion issue
-- conditionally (on the right side of And Then/Or Else. This call
-- removes only embedded checks (Do_Range_Check, Do_Overflow_Check).
- procedure Validity_Check_Range (N : Node_Id);
- -- If N is an N_Range node, then Ensure_Valid is called on its bounds,
- -- if validity checking of operands is enabled.
+ procedure Validity_Check_Range
+ (N : Node_Id;
+ Related_Id : Entity_Id := Empty);
+ -- If N is an N_Range node, then Ensure_Valid is called on its bounds, if
+ -- validity checking of operands is enabled. Related_Id denotes the entity
+ -- of the context where N appears.
-----------------------------
-- Handling of Check Names --
---------------------------------
function Duplicate_Subexpr_No_Checks
- (Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False) return Node_Id
+ (Exp : Node_Id;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False;
+ Related_Id : Entity_Id := Empty;
+ Is_Low_Bound : Boolean := False;
+ Is_High_Bound : Boolean := False) return Node_Id
is
New_Exp : Node_Id;
begin
- Remove_Side_Effects (Exp, Name_Req, Renaming_Req);
+ Remove_Side_Effects
+ (Exp => Exp,
+ Name_Req => Name_Req,
+ Renaming_Req => Renaming_Req,
+ Related_Id => Related_Id,
+ Is_Low_Bound => Is_Low_Bound,
+ Is_High_Bound => Is_High_Bound);
+
New_Exp := New_Copy_Tree (Exp);
Remove_Checks (New_Exp);
return New_Exp;
-------------------------
procedure Remove_Side_Effects
- (Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False;
- Variable_Ref : Boolean := False)
+ (Exp : Node_Id;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False;
+ Variable_Ref : Boolean := False;
+ Related_Id : Entity_Id := Empty;
+ Is_Low_Bound : Boolean := False;
+ Is_High_Bound : Boolean := False)
is
+ function Build_Temporary
+ (Loc : Source_Ptr;
+ Id : Character;
+ Related_Nod : Node_Id := Empty) return Entity_Id;
+ -- Create an external symbol of the form xxx_FIRST/_LAST if Related_Id
+ -- is present, otherwise it generates an internal temporary.
+
+ ---------------------
+ -- Build_Temporary --
+ ---------------------
+
+ function Build_Temporary
+ (Loc : Source_Ptr;
+ Id : Character;
+ Related_Nod : Node_Id := Empty) return Entity_Id
+ is
+ Temp_Nam : Name_Id;
+
+ begin
+ -- The context requires an external symbol
+
+ if Present (Related_Id) then
+ if Is_Low_Bound then
+ Temp_Nam := New_External_Name (Chars (Related_Id), "_FIRST");
+ else pragma Assert (Is_High_Bound);
+ Temp_Nam := New_External_Name (Chars (Related_Id), "_LAST");
+ end if;
+
+ return Make_Defining_Identifier (Loc, Temp_Nam);
+
+ -- Otherwise generate an internal temporary
+
+ else
+ return Make_Temporary (Loc, Id, Related_Nod);
+ end if;
+ end Build_Temporary;
+
+ -- Local variables
+
Loc : constant Source_Ptr := Sloc (Exp);
Exp_Type : constant Entity_Id := Etype (Exp);
Svg_Suppress : constant Suppress_Record := Scope_Suppress;
Ref_Type : Entity_Id;
Res : Node_Id;
+ -- Start of processing for Remove_Side_Effects
+
begin
-- Handle cases in which there is nothing to do. In GNATprove mode,
-- removal of side effects is useful for the light expansion of
or else (not Name_Req
and then Is_Volatile_Reference (Exp)))
then
- Def_Id := Make_Temporary (Loc, 'R', Exp);
+ Def_Id := Build_Temporary (Loc, 'R', Exp);
Set_Etype (Def_Id, Exp_Type);
Res := New_Occurrence_Of (Def_Id, Loc);
elsif Nkind (Exp) = N_Explicit_Dereference
and then not Is_Volatile_Reference (Exp)
then
- Def_Id := Make_Temporary (Loc, 'R', Exp);
+ Def_Id := Build_Temporary (Loc, 'R', Exp);
Res :=
Make_Explicit_Dereference (Loc, New_Occurrence_Of (Def_Id, Loc));
-- Use a renaming to capture the expression, rather than create
-- a controlled temporary.
- Def_Id := Make_Temporary (Loc, 'R', Exp);
- Res := New_Occurrence_Of (Def_Id, Loc);
+ Def_Id := Build_Temporary (Loc, 'R', Exp);
+ Res := New_Occurrence_Of (Def_Id, Loc);
Insert_Action (Exp,
Make_Object_Renaming_Declaration (Loc,
Name => Relocate_Node (Exp)));
else
- Def_Id := Make_Temporary (Loc, 'R', Exp);
+ Def_Id := Build_Temporary (Loc, 'R', Exp);
Set_Etype (Def_Id, Exp_Type);
- Res := New_Occurrence_Of (Def_Id, Loc);
+ Res := New_Occurrence_Of (Def_Id, Loc);
E :=
Make_Object_Declaration (Loc,
and then (Name_Req or else not Treat_As_Volatile (Exp_Type))
then
- Def_Id := Make_Temporary (Loc, 'R', Exp);
+ Def_Id := Build_Temporary (Loc, 'R', Exp);
if Nkind (Exp) = N_Selected_Component
and then Nkind (Prefix (Exp)) = N_Function_Call
end;
end if;
- Def_Id := Make_Temporary (Loc, 'R', Exp);
+ Def_Id := Build_Temporary (Loc, 'R', Exp);
-- The regular expansion of functions with side effects involves the
-- generation of an access type to capture the return value found on
-- following functions allow this behavior to be modified.
function Duplicate_Subexpr_No_Checks
- (Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False) return Node_Id;
- -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks
- -- is called on the result, so that the duplicated expression does not
- -- include checks. This is appropriate for use when Exp, the original
- -- expression is unconditionally elaborated before the duplicated
- -- expression, so that there is no need to repeat any checks.
+ (Exp : Node_Id;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False;
+ Related_Id : Entity_Id := Empty;
+ Is_Low_Bound : Boolean := False;
+ Is_High_Bound : Boolean := False) return Node_Id;
+ -- Identical in effect to Duplicate_Subexpr, except that Remove_Checks is
+ -- called on the result, so that the duplicated expression does not include
+ -- checks. This is appropriate for use when Exp, the original expression is
+ -- unconditionally elaborated before the duplicated expression, so that
+ -- there is no need to repeat any checks.
+ --
+ -- Related_Id denotes the entity of the context where Expr appears. Flags
+ -- Is_Low_Bound and Is_High_Bound specify whether the expression to check
+ -- is the low or the high bound of a range. These three optional arguments
+ -- signal Remove_Side_Effects to create an external symbol of the form
+ -- Chars (Related_Id)_FIRST/_LAST.
function Duplicate_Subexpr_Move_Checks
(Exp : Node_Id;
-- associated with Var, and if found, remove and return that call node.
procedure Remove_Side_Effects
- (Exp : Node_Id;
- Name_Req : Boolean := False;
- Renaming_Req : Boolean := False;
- Variable_Ref : Boolean := False);
+ (Exp : Node_Id;
+ Name_Req : Boolean := False;
+ Renaming_Req : Boolean := False;
+ Variable_Ref : Boolean := False;
+ Related_Id : Entity_Id := Empty;
+ Is_Low_Bound : Boolean := False;
+ Is_High_Bound : Boolean := False);
-- Given the node for a subexpression, this function replaces the node if
-- necessary by an equivalent subexpression that is guaranteed to be side
-- effect free. This is done by extracting any actions that could cause
-- 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.
+ --
+ -- Related_Id denotes the entity of the context where Expr appears. Flags
+ -- Is_Low_Bound and Is_High_Bound specify whether the expression to check
+ -- is the low or the high bound of a range. These three optional arguments
+ -- signal Remove_Side_Effects to create an external symbol of the form
+ -- Chars (Related_Id)_FIRST/_LAST. If Related_Id is set, the exactly one
+ -- of the Is_xxx_Bound flags must be set.
function Represented_As_Scalar (T : Entity_Id) return Boolean;
-- Returns True iff the implementation of this type in code generation
Lo := Low_Bound (R);
Hi := High_Bound (R);
- -- We need to ensure validity of the bounds here, because if we
- -- go ahead and do the expansion, then the expanded code will get
- -- analyzed with range checks suppressed and we miss the check.
-- Validity checks on the range of a quantified expression are
-- delayed until the construct is transformed into a loop.
- if Nkind (Parent (R)) /= N_Loop_Parameter_Specification
- or else Nkind (Parent (Parent (R))) /= N_Quantified_Expression
+ if Nkind (Parent (R)) = N_Loop_Parameter_Specification
+ and then Nkind (Parent (Parent (R))) = N_Quantified_Expression
then
- Validity_Check_Range (R);
+ null;
+
+ -- We need to ensure validity of the bounds here, because if we
+ -- go ahead and do the expansion, then the expanded code will get
+ -- analyzed with range checks suppressed and we miss the check.
+
+ -- WARNING: The capture of the range bounds with xxx_FIRST/_LAST and
+ -- the temporaries generated by routine Remove_Side_Effects by means
+ -- of validity checks must use the same names. When a range appears
+ -- in the parent of a generic, the range is processed with checks
+ -- disabled as part of the generic context and with checks enabled
+ -- for code generation purposes. This leads to link issues as the
+ -- generic contains references to xxx_FIRST/_LAST, but the inlined
+ -- template sees the temporaries generated by Remove_Side_Effects.
+
+ else
+ Validity_Check_Range (R, Subtyp);
end if;
-- If there were errors in the declaration, try and patch up some
if Nkind (Lo) = N_String_Literal then
Rewrite (Lo,
Make_Attribute_Reference (Sloc (Lo),
- Attribute_Name => Name_First,
- Prefix => New_Occurrence_Of (T, Sloc (Lo))));
+ Prefix => New_Occurrence_Of (T, Sloc (Lo)),
+ Attribute_Name => Name_First));
Analyze_And_Resolve (Lo);
end if;
if Nkind (Hi) = N_String_Literal then
Rewrite (Hi,
Make_Attribute_Reference (Sloc (Hi),
- Attribute_Name => Name_First,
- Prefix => New_Occurrence_Of (T, Sloc (Hi))));
+ Prefix => New_Occurrence_Of (T, Sloc (Hi)),
+ Attribute_Name => Name_First));
Analyze_And_Resolve (Hi);
end if;
projects / gcc.git / commitdiff