From 2934b84ad8624e08f1390f9bf2cf95a0093f4f1b Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Thu, 23 Oct 2014 12:11:21 +0200 Subject: [PATCH] [multiple changes] 2014-10-23 Hristian Kirtchev * 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 * a-strsea.adb: Minor reformatting. From-SVN: r216581 --- gcc/ada/ChangeLog | 31 ++++++++++++++++ gcc/ada/a-strsea.adb | 22 ++++++------ gcc/ada/checks.adb | 61 ++++++++++++++++++++++--------- gcc/ada/checks.ads | 40 ++++++++++++++++----- gcc/ada/exp_util.adb | 86 +++++++++++++++++++++++++++++++++++--------- gcc/ada/exp_util.ads | 43 +++++++++++++++------- gcc/ada/sem_ch3.adb | 33 +++++++++++------ 7 files changed, 243 insertions(+), 73 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index c07d3eef96d..85917acb087 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2014-10-23 Hristian Kirtchev + + * 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 + + * a-strsea.adb: Minor reformatting. + 2014-10-23 Thomas Quinot * bcheck.adb (Check_Consistent_SSO_Default): Exclude internal diff --git a/gcc/ada/a-strsea.adb b/gcc/ada/a-strsea.adb index 2651dc8d989..dd3d75c143a 100644 --- a/gcc/ada/a-strsea.adb +++ b/gcc/ada/a-strsea.adb @@ -241,14 +241,6 @@ package body Ada.Strings.Search is 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 @@ -271,8 +263,18 @@ package body Ada.Strings.Search is -- 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; ----------- diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 05f4b7e476a..046c5177f3c 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -5627,7 +5627,13 @@ package body Checks is -- 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 @@ -5793,7 +5799,7 @@ package body Checks is -- 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)) @@ -6996,14 +7002,19 @@ package body Checks is -- 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) @@ -7073,7 +7084,13 @@ package body Checks is -- 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 @@ -7098,14 +7115,14 @@ package body Checks is -- 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 @@ -10113,12 +10130,22 @@ package body Checks is -- 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; diff --git a/gcc/ada/checks.ads b/gcc/ada/checks.ads index 2dca67e1c4a..15a456b1117 100644 --- a/gcc/ada/checks.ads +++ b/gcc/ada/checks.ads @@ -849,7 +849,12 @@ package Checks is -- 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 @@ -865,6 +870,12 @@ package Checks is -- 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 @@ -876,10 +887,20 @@ package Checks is -- 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 @@ -889,9 +910,12 @@ package Checks is -- 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 -- diff --git a/gcc/ada/exp_util.adb b/gcc/ada/exp_util.adb index 562a54de95c..b43731d30eb 100644 --- a/gcc/ada/exp_util.adb +++ b/gcc/ada/exp_util.adb @@ -1922,14 +1922,24 @@ package body Exp_Util is --------------------------------- 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; @@ -7188,11 +7198,53 @@ package body Exp_Util is ------------------------- 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; @@ -7203,6 +7255,8 @@ package body Exp_Util is 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 @@ -7260,7 +7314,7 @@ package body Exp_Util is 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); @@ -7309,7 +7363,7 @@ package body Exp_Util is 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)); @@ -7351,8 +7405,8 @@ package body Exp_Util is -- 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, @@ -7361,9 +7415,9 @@ package body Exp_Util is 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, @@ -7397,7 +7451,7 @@ package body Exp_Util is 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 @@ -7490,7 +7544,7 @@ package body Exp_Util is 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 diff --git a/gcc/ada/exp_util.ads b/gcc/ada/exp_util.ads index 871a5ba5744..ef319fd56c4 100644 --- a/gcc/ada/exp_util.ads +++ b/gcc/ada/exp_util.ads @@ -372,14 +372,23 @@ package Exp_Util is -- 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; @@ -823,10 +832,13 @@ package Exp_Util is -- 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 @@ -840,6 +852,13 @@ package Exp_Util is -- 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 diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index a6368da44fc..2f0f194e71b 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -19734,16 +19734,29 @@ package body Sem_Ch3 is 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 @@ -19784,16 +19797,16 @@ package body Sem_Ch3 is 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; -- 2.30.2