From 634a926b69be65a7b7db39f74538a91a98a89eab Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Tue, 25 Apr 2017 15:19:23 +0200 Subject: [PATCH] [multiple changes] 2017-04-25 Hristian Kirtchev * comperr.adb (Compiler_Abort): Add a pair of pragma Warnings On/Off to defend against a spurious warning in conditional compilation. * exp_ch4.adb (Rewrite_Comparison): Reimplemented. * namet.adb (Finalize): Add a pair of pragma Warnings On/Off to defend against a spurious warning in conditional compilation. * output.adb Add a pair of pragma Warnings On/Off to defend against a spurious warning in conditional compilation. * sem_eval.adb (Eval_Relational_Op): Major code clean up. (Fold_General_Op): New routine. (Fold_Static_Real_Op): New routine. (Test_Comparison): New routine. * sem_eval.ads (Test_Comparison): New routine. * sem_warn.adb (Is_Attribute_Constant_Comparison): New routine. (Warn_On_Constant_Valid_Condition): New routine. (Warn_On_Known_Condition): Use Is_Attribute_Constant_Comparison to detect a specific case. * sem_warn.adb (Warn_On_Constant_Valid_Condition): New routine. * urealp.adb (Tree_Read): Add a pair of pragma Warnings On/Off to defend against a spurious warning in conditional compilation. (Tree_Write): Add a pair of pragma Warnings On/Off to defend against a spurious warning in conditional compilation. * usage.adb Add a pair of pragma Warnings On/Off to defend against a spurious warning in conditional compilation. 2017-04-25 Arnaud Charlet * sinfo.ads, sem_ch13.adb: Update comment. From-SVN: r247224 --- gcc/ada/ChangeLog | 31 ++ gcc/ada/comperr.adb | 9 + gcc/ada/exp_ch4.adb | 142 ++------- gcc/ada/namet.adb | 11 +- gcc/ada/output.adb | 7 +- gcc/ada/sem_ch13.adb | 3 +- gcc/ada/sem_eval.adb | 695 ++++++++++++++++++++++++------------------- gcc/ada/sem_eval.ads | 12 +- gcc/ada/sem_warn.adb | 82 ++++- gcc/ada/sem_warn.ads | 7 +- gcc/ada/sinfo.ads | 3 +- gcc/ada/urealp.adb | 16 +- gcc/ada/usage.adb | 10 +- 13 files changed, 585 insertions(+), 443 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 27c0af01c89..d83d4f651f2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,34 @@ +2017-04-25 Hristian Kirtchev + + * comperr.adb (Compiler_Abort): Add a pair of pragma Warnings + On/Off to defend against a spurious warning in conditional + compilation. + * exp_ch4.adb (Rewrite_Comparison): Reimplemented. + * namet.adb (Finalize): Add a pair of pragma Warnings On/Off to + defend against a spurious warning in conditional compilation. + * output.adb Add a pair of pragma Warnings On/Off to defend + against a spurious warning in conditional compilation. + * sem_eval.adb (Eval_Relational_Op): Major code clean up. + (Fold_General_Op): New routine. + (Fold_Static_Real_Op): New routine. + (Test_Comparison): New routine. + * sem_eval.ads (Test_Comparison): New routine. + * sem_warn.adb (Is_Attribute_Constant_Comparison): New routine. + (Warn_On_Constant_Valid_Condition): New routine. + (Warn_On_Known_Condition): Use Is_Attribute_Constant_Comparison + to detect a specific case. + * sem_warn.adb (Warn_On_Constant_Valid_Condition): New routine. + * urealp.adb (Tree_Read): Add a pair of pragma Warnings On/Off + to defend against a spurious warning in conditional compilation. + (Tree_Write): Add a pair of pragma Warnings On/Off to defend + against a spurious warning in conditional compilation. + * usage.adb Add a pair of pragma Warnings On/Off to defend + against a spurious warning in conditional compilation. + +2017-04-25 Arnaud Charlet + + * sinfo.ads, sem_ch13.adb: Update comment. + 2017-04-25 Hristian Kirtchev * sem_util.adb (Is_Post_State): A reference to a diff --git a/gcc/ada/comperr.adb b/gcc/ada/comperr.adb index 04035241830..b3e20a41f1a 100644 --- a/gcc/ada/comperr.adb +++ b/gcc/ada/comperr.adb @@ -98,9 +98,18 @@ package body Comperr is Write_Eol; end End_Line; + -- Disable the warnings emitted by -gnatwc because the following two + -- constants are initialized by means of conditional compilation. + + pragma Warnings + (Off, "condition can only be * if invalid values present"); + Is_GPL_Version : constant Boolean := Gnatvsn.Build_Type = GPL; Is_FSF_Version : constant Boolean := Gnatvsn.Build_Type = FSF; + pragma Warnings + (On, "condition can only be * if invalid values present"); + -- Start of processing for Compiler_Abort begin diff --git a/gcc/ada/exp_ch4.adb b/gcc/ada/exp_ch4.adb index bc0aea2e2cd..7070781b6cb 100644 --- a/gcc/ada/exp_ch4.adb +++ b/gcc/ada/exp_ch4.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -13211,12 +13211,10 @@ package body Exp_Ch4 is ------------------------ procedure Rewrite_Comparison (N : Node_Id) is - Warning_Generated : Boolean := False; - -- Set to True if first pass with Assume_Valid generates a warning in - -- which case we skip the second pass to avoid warning overloaded. + Typ : constant Entity_Id := Etype (N); - Result : Node_Id; - -- Set to Standard_True or Standard_False + False_Result : Boolean; + True_Result : Boolean; begin if Nkind (N) = N_Type_Conversion then @@ -13227,125 +13225,31 @@ package body Exp_Ch4 is return; end if; - -- Now start looking at the comparison in detail. We potentially go - -- through this loop twice. The first time, Assume_Valid is set False - -- in the call to Compile_Time_Compare. If this call results in a - -- clear result of always True or Always False, that's decisive and - -- we are done. Otherwise we repeat the processing with Assume_Valid - -- set to True to generate additional warnings. We can skip that step - -- if Constant_Condition_Warnings is False. + -- Determine the potential outcome of the comparison assuming that the + -- operands are valid and emit a warning when the comparison evaluates + -- to True or False only in the presence of invalid values. - for AV in False .. True loop - declare - Typ : constant Entity_Id := Etype (N); - Op1 : constant Node_Id := Left_Opnd (N); - Op2 : constant Node_Id := Right_Opnd (N); + Warn_On_Constant_Valid_Condition (N); - Res : constant Compare_Result := - Compile_Time_Compare (Op1, Op2, Assume_Valid => AV); - -- Res indicates if compare outcome can be compile time determined + -- Determine the potential outcome of the comparison assuming that the + -- operands are not valid. - True_Result : Boolean; - False_Result : Boolean; - - begin - case N_Op_Compare (Nkind (N)) is - when N_Op_Eq => - True_Result := Res = EQ; - False_Result := Res = LT or else Res = GT or else Res = NE; - - when N_Op_Ge => - True_Result := Res in Compare_GE; - False_Result := Res = LT; - - if Res = LE - and then Constant_Condition_Warnings - and then Comes_From_Source (Original_Node (N)) - and then Nkind (Original_Node (N)) = N_Op_Ge - and then not In_Instance - and then Is_Integer_Type (Etype (Left_Opnd (N))) - and then not Has_Warnings_Off (Etype (Left_Opnd (N))) - then - Error_Msg_N - ("can never be greater than, could replace by " - & """'=""?c?", N); - Warning_Generated := True; - end if; - - when N_Op_Gt => - True_Result := Res = GT; - False_Result := Res in Compare_LE; - - when N_Op_Lt => - True_Result := Res = LT; - False_Result := Res in Compare_GE; - - when N_Op_Le => - True_Result := Res in Compare_LE; - False_Result := Res = GT; - - if Res = GE - and then Constant_Condition_Warnings - and then Comes_From_Source (Original_Node (N)) - and then Nkind (Original_Node (N)) = N_Op_Le - and then not In_Instance - and then Is_Integer_Type (Etype (Left_Opnd (N))) - and then not Has_Warnings_Off (Etype (Left_Opnd (N))) - then - Error_Msg_N - ("can never be less than, could replace by ""'=""?c?", - N); - Warning_Generated := True; - end if; - - when N_Op_Ne => - True_Result := Res = NE or else Res = GT or else Res = LT; - False_Result := Res = EQ; - end case; - - -- If this is the first iteration, then we actually convert the - -- comparison into True or False, if the result is certain. - - if AV = False then - if True_Result or False_Result then - Result := Boolean_Literals (True_Result); - Rewrite (N, - Convert_To (Typ, - New_Occurrence_Of (Result, Sloc (N)))); - Analyze_And_Resolve (N, Typ); - Warn_On_Known_Condition (N); - return; - end if; + Test_Comparison + (Op => N, + Assume_Valid => False, + True_Result => True_Result, + False_Result => False_Result); - -- If this is the second iteration (AV = True), and the original - -- node comes from source and we are not in an instance, then give - -- a warning if we know result would be True or False. Note: we - -- know Constant_Condition_Warnings is set if we get here. + -- The outcome is a decisive False or True, rewrite the operator - elsif Comes_From_Source (Original_Node (N)) - and then not In_Instance - then - if True_Result then - Error_Msg_N - ("condition can only be False if invalid values present??", - N); - elsif False_Result then - Error_Msg_N - ("condition can only be True if invalid values present??", - N); - end if; - end if; - end; - - -- Skip second iteration if not warning on constant conditions or - -- if the first iteration already generated a warning of some kind or - -- if we are in any case assuming all values are valid (so that the - -- first iteration took care of the valid case). + if False_Result or True_Result then + Rewrite (N, + Convert_To (Typ, + New_Occurrence_Of (Boolean_Literals (True_Result), Sloc (N)))); - exit when not Constant_Condition_Warnings; - exit when Warning_Generated; - exit when Assume_No_Invalid_Values; - end loop; + Analyze_And_Resolve (N, Typ); + Warn_On_Known_Condition (N); + end if; end Rewrite_Comparison; ---------------------------- diff --git a/gcc/ada/namet.adb b/gcc/ada/namet.adb index 6e599095771..a1610468a74 100644 --- a/gcc/ada/namet.adb +++ b/gcc/ada/namet.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -672,6 +672,12 @@ package body Namet is Max_Chain_Length := C; end if; + -- Disable the warnings emitted by -gnatwc because the tests + -- involving Verbosity involve conditional compilation. + + pragma Warnings + (Off, "condition can only be * if invalid values present"); + if Verbosity >= 2 then Write_Str ("Hash_Table ("); Write_Int (J); @@ -703,6 +709,9 @@ package body Namet is N := Name_Entries.Table (N).Hash_Link; end loop; end if; + + pragma Warnings + (On, "condition can only be * if invalid values present"); end; end if; end loop; diff --git a/gcc/ada/output.adb b/gcc/ada/output.adb index fdfb7330a20..34e54d838f6 100644 --- a/gcc/ada/output.adb +++ b/gcc/ada/output.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -55,7 +55,12 @@ package body Output is Indentation_Limit : constant Positive := 40; -- Indentation beyond this number of spaces wraps around + -- Disable the warnings emitted by -gnatwc because the comparison within + -- the assertion depends on conditional compilation. + + pragma Warnings (Off, "condition can only be * if invalid values present"); pragma Assert (Indentation_Limit < Buffer_Max / 2); + pragma Warnings (On, "condition can only be * if invalid values present"); -- Make sure this is substantially shorter than the line length Cur_Indentation : Natural := 0; diff --git a/gcc/ada/sem_ch13.adb b/gcc/ada/sem_ch13.adb index ea7b3f47e44..ca8a5cc9f5d 100644 --- a/gcc/ada/sem_ch13.adb +++ b/gcc/ada/sem_ch13.adb @@ -2456,7 +2456,8 @@ package body Sem_Ch13 is goto Continue; - -- For tasks pass the aspect as an attribute + -- For task and protected types pass the aspect as an + -- attribute. else Aitem := diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb index 5a8c27b7437..855614957d4 100644 --- a/gcc/ada/sem_eval.adb +++ b/gcc/ada/sem_eval.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -3144,274 +3144,364 @@ package body Sem_Eval is -- equality test A = "ABC", and the former is definitely static. procedure Eval_Relational_Op (N : Node_Id) is - Left : constant Node_Id := Left_Opnd (N); - Right : constant Node_Id := Right_Opnd (N); - Typ : constant Entity_Id := Etype (Left); - Otype : Entity_Id := Empty; - Result : Boolean; + Left : constant Node_Id := Left_Opnd (N); + Right : constant Node_Id := Right_Opnd (N); - begin - -- One special case to deal with first. If we can tell that the result - -- will be false because the lengths of one or more index subtypes are - -- compile time known and different, then we can replace the entire - -- result by False. We only do this for one dimensional arrays, because - -- the case of multi-dimensional arrays is rare and too much trouble. If - -- one of the operands is an illegal aggregate, its type might still be - -- an arbitrary composite type, so nothing to do. + procedure Decompose_Expr + (Expr : Node_Id; + Ent : out Entity_Id; + Kind : out Character; + Cons : out Uint; + Orig : Boolean := True); + -- Given expression Expr, see if it is of the form X [+/- K]. If so, Ent + -- is set to the entity in X, Kind is 'F','L','E' for 'First or 'Last or + -- simple entity, and Cons is the value of K. If the expression is not + -- of the required form, Ent is set to Empty. + -- + -- Orig indicates whether Expr is the original expression to consider, + -- or if we are handling a sub-expression (e.g. recursive call to + -- Decompose_Expr). + + procedure Fold_General_Op (Is_Static : Boolean); + -- Attempt to fold arbitrary relational operator N. Flag Is_Static must + -- be set when the operator denotes a static expression. + + procedure Fold_Static_Real_Op; + -- Attempt to fold static real type relational operator N + + function Static_Length (Expr : Node_Id) return Uint; + -- If Expr is an expression for a constrained array whose length is + -- known at compile time, return the non-negative length, otherwise + -- return -1. + + -------------------- + -- Decompose_Expr -- + -------------------- + + procedure Decompose_Expr + (Expr : Node_Id; + Ent : out Entity_Id; + Kind : out Character; + Cons : out Uint; + Orig : Boolean := True) + is + Exp : Node_Id; - if Is_Array_Type (Typ) - and then Typ /= Any_Composite - and then Number_Dimensions (Typ) = 1 - and then (Nkind (N) = N_Op_Eq or else Nkind (N) = N_Op_Ne) - then - if Raises_Constraint_Error (Left) - or else - Raises_Constraint_Error (Right) + begin + -- Assume that the expression does not meet the expected form + + Cons := No_Uint; + Ent := Empty; + Kind := '?'; + + if Nkind (Expr) = N_Op_Add + and then Compile_Time_Known_Value (Right_Opnd (Expr)) then - return; + Exp := Left_Opnd (Expr); + Cons := Expr_Value (Right_Opnd (Expr)); + + elsif Nkind (Expr) = N_Op_Subtract + and then Compile_Time_Known_Value (Right_Opnd (Expr)) + then + Exp := Left_Opnd (Expr); + Cons := -Expr_Value (Right_Opnd (Expr)); + + -- If the bound is a constant created to remove side effects, recover + -- the original expression to see if it has one of the recognizable + -- forms. + + elsif Nkind (Expr) = N_Identifier + and then not Comes_From_Source (Entity (Expr)) + and then Ekind (Entity (Expr)) = E_Constant + and then Nkind (Parent (Entity (Expr))) = N_Object_Declaration + then + Exp := Expression (Parent (Entity (Expr))); + Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False); + + -- If original expression includes an entity, create a reference + -- to it for use below. + + if Present (Ent) then + Exp := New_Occurrence_Of (Ent, Sloc (Ent)); + else + return; + end if; + + else + -- Only consider the case of X + 0 for a full expression, and + -- not when recursing, otherwise we may end up with evaluating + -- expressions not known at compile time to 0. + + if Orig then + Exp := Expr; + Cons := Uint_0; + else + return; + end if; end if; - -- OK, we have the case where we may be able to do this fold + -- At this stage Exp is set to the potential X - Length_Mismatch : declare - procedure Get_Static_Length (Op : Node_Id; Len : out Uint); - -- If Op is an expression for a constrained array with a known at - -- compile time length, then Len is set to this (non-negative - -- length). Otherwise Len is set to minus 1. + if Nkind (Exp) = N_Attribute_Reference then + if Attribute_Name (Exp) = Name_First then + Kind := 'F'; + elsif Attribute_Name (Exp) = Name_Last then + Kind := 'L'; + else + return; + end if; - ----------------------- - -- Get_Static_Length -- - ----------------------- + Exp := Prefix (Exp); - procedure Get_Static_Length (Op : Node_Id; Len : out Uint) is - T : Entity_Id; + else + Kind := 'E'; + end if; - begin - -- First easy case string literal + if Is_Entity_Name (Exp) and then Present (Entity (Exp)) then + Ent := Entity (Exp); + end if; + end Decompose_Expr; + + --------------------- + -- Fold_General_Op -- + --------------------- + + procedure Fold_General_Op (Is_Static : Boolean) is + CR : constant Compare_Result := + Compile_Time_Compare (Left, Right, Assume_Valid => False); - if Nkind (Op) = N_String_Literal then - Len := UI_From_Int (String_Length (Strval (Op))); + Result : Boolean; + + begin + if CR = Unknown then + return; + end if; + + case Nkind (N) is + when N_Op_Eq => + if CR = EQ then + Result := True; + elsif CR = NE or else CR = GT or else CR = LT then + Result := False; + else return; end if; - -- Second easy case, not constrained subtype, so no length - - if not Is_Constrained (Etype (Op)) then - Len := Uint_Minus_1; + when N_Op_Ge => + if CR = GT or else CR = EQ or else CR = GE then + Result := True; + elsif CR = LT then + Result := False; + else return; end if; - -- General case + when N_Op_Gt => + if CR = GT then + Result := True; + elsif CR = EQ or else CR = LT or else CR = LE then + Result := False; + else + return; + end if; - T := Etype (First_Index (Etype (Op))); + when N_Op_Le => + if CR = LT or else CR = EQ or else CR = LE then + Result := True; + elsif CR = GT then + Result := False; + else + return; + end if; - -- The simple case, both bounds are known at compile time + when N_Op_Lt => + if CR = LT then + Result := True; + elsif CR = EQ or else CR = GT or else CR = GE then + Result := False; + else + return; + end if; - if Is_Discrete_Type (T) - and then Compile_Time_Known_Value (Type_Low_Bound (T)) - and then Compile_Time_Known_Value (Type_High_Bound (T)) - then - Len := UI_Max (Uint_0, - Expr_Value (Type_High_Bound (T)) - - Expr_Value (Type_Low_Bound (T)) + 1); + when N_Op_Ne => + if CR = NE or else CR = GT or else CR = LT then + Result := True; + elsif CR = EQ then + Result := False; + else return; end if; - -- A more complex case, where the bounds are of the form - -- X [+/- K1] .. X [+/- K2]), where X is an expression that is - -- either A'First or A'Last (with A an entity name), or X is an - -- entity name, and the two X's are the same and K1 and K2 are - -- known at compile time, in this case, the length can also be - -- computed at compile time, even though the bounds are not - -- known. A common case of this is e.g. (X'First .. X'First+5). - - Extract_Length : declare - procedure Decompose_Expr - (Expr : Node_Id; - Ent : out Entity_Id; - Kind : out Character; - Cons : out Uint; - Orig : Boolean := True); - -- Given an expression see if it is of the form given above, - -- X [+/- K]. If so Ent is set to the entity in X, Kind is - -- 'F','L','E' for 'First/'Last/simple entity, and Cons is - -- the value of K. If the expression is not of the required - -- form, Ent is set to Empty. - -- - -- Orig indicates whether Expr is the original expression - -- to consider, or if we are handling a sub-expression - -- (e.g. recursive call to Decompose_Expr). - - -------------------- - -- Decompose_Expr -- - -------------------- - - procedure Decompose_Expr - (Expr : Node_Id; - Ent : out Entity_Id; - Kind : out Character; - Cons : out Uint; - Orig : Boolean := True) - is - Exp : Node_Id; + when others => + raise Program_Error; + end case; - begin - Ent := Empty; + -- Determine the potential outcome of the relation assuming the + -- operands are valid and emit a warning when the relation yields + -- True or False only in the presence of invalid values. - -- Ignored values: + Warn_On_Constant_Valid_Condition (N); - Kind := '?'; - Cons := No_Uint; + Fold_Uint (N, Test (Result), Is_Static); + end Fold_General_Op; - if Nkind (Expr) = N_Op_Add - and then Compile_Time_Known_Value (Right_Opnd (Expr)) - then - Exp := Left_Opnd (Expr); - Cons := Expr_Value (Right_Opnd (Expr)); + ------------------------- + -- Fold_Static_Real_Op -- + ------------------------- - elsif Nkind (Expr) = N_Op_Subtract - and then Compile_Time_Known_Value (Right_Opnd (Expr)) - then - Exp := Left_Opnd (Expr); - Cons := -Expr_Value (Right_Opnd (Expr)); + procedure Fold_Static_Real_Op is + Left_Real : constant Ureal := Expr_Value_R (Left); + Right_Real : constant Ureal := Expr_Value_R (Right); + Result : Boolean; - -- If the bound is a constant created to remove side - -- effects, recover original expression to see if it has - -- one of the recognizable forms. + begin + case Nkind (N) is + when N_Op_Eq => Result := (Left_Real = Right_Real); + when N_Op_Ge => Result := (Left_Real >= Right_Real); + when N_Op_Gt => Result := (Left_Real > Right_Real); + when N_Op_Le => Result := (Left_Real <= Right_Real); + when N_Op_Lt => Result := (Left_Real < Right_Real); + when N_Op_Ne => Result := (Left_Real /= Right_Real); + when others => raise Program_Error; + end case; + + Fold_Uint (N, Test (Result), True); + end Fold_Static_Real_Op; - elsif Nkind (Expr) = N_Identifier - and then not Comes_From_Source (Entity (Expr)) - and then Ekind (Entity (Expr)) = E_Constant - and then - Nkind (Parent (Entity (Expr))) = N_Object_Declaration - then - Exp := Expression (Parent (Entity (Expr))); - Decompose_Expr (Exp, Ent, Kind, Cons, Orig => False); + ------------------- + -- Static_Length -- + ------------------- - -- If original expression includes an entity, create a - -- reference to it for use below. + function Static_Length (Expr : Node_Id) return Uint is + Cons1 : Uint; + Cons2 : Uint; + Ent1 : Entity_Id; + Ent2 : Entity_Id; + Kind1 : Character; + Kind2 : Character; + Typ : Entity_Id; - if Present (Ent) then - Exp := New_Occurrence_Of (Ent, Sloc (Ent)); - else - return; - end if; + begin + -- First easy case string literal - else - -- Only consider the case of X + 0 for a full - -- expression, and not when recursing, otherwise we - -- may end up with evaluating expressions not known - -- at compile time to 0. - - if Orig then - Exp := Expr; - Cons := Uint_0; - else - return; - end if; - end if; + if Nkind (Expr) = N_String_Literal then + return UI_From_Int (String_Length (Strval (Expr))); - -- At this stage Exp is set to the potential X + -- Second easy case, not constrained subtype, so no length - if Nkind (Exp) = N_Attribute_Reference then - if Attribute_Name (Exp) = Name_First then - Kind := 'F'; - elsif Attribute_Name (Exp) = Name_Last then - Kind := 'L'; - else - return; - end if; + elsif not Is_Constrained (Etype (Expr)) then + return Uint_Minus_1; + end if; - Exp := Prefix (Exp); + -- General case - else - Kind := 'E'; - end if; + Typ := Etype (First_Index (Etype (Expr))); - if Is_Entity_Name (Exp) - and then Present (Entity (Exp)) - then - Ent := Entity (Exp); - end if; - end Decompose_Expr; + -- The simple case, both bounds are known at compile time - -- Local Variables + if Is_Discrete_Type (Typ) + and then Compile_Time_Known_Value (Type_Low_Bound (Typ)) + and then Compile_Time_Known_Value (Type_High_Bound (Typ)) + then + return + UI_Max (Uint_0, Expr_Value (Type_High_Bound (Typ)) - + Expr_Value (Type_Low_Bound (Typ)) + 1); + end if; - Ent1, Ent2 : Entity_Id; - Kind1, Kind2 : Character; - Cons1, Cons2 : Uint; + -- A more complex case, where the bounds are of the form X [+/- K1] + -- .. X [+/- K2]), where X is an expression that is either A'First or + -- A'Last (with A an entity name), or X is an entity name, and the + -- two X's are the same and K1 and K2 are known at compile time, in + -- this case, the length can also be computed at compile time, even + -- though the bounds are not known. A common case of this is e.g. + -- (X'First .. X'First+5). + + Decompose_Expr + (Original_Node (Type_Low_Bound (Typ)), Ent1, Kind1, Cons1); + Decompose_Expr + (Original_Node (Type_High_Bound (Typ)), Ent2, Kind2, Cons2); + + if Present (Ent1) and then Ent1 = Ent2 and then Kind1 = Kind2 then + return Cons2 - Cons1 + 1; + else + return Uint_Minus_1; + end if; + end Static_Length; - -- Start of processing for Extract_Length + -- Local variables - begin - Decompose_Expr - (Original_Node (Type_Low_Bound (T)), Ent1, Kind1, Cons1); - Decompose_Expr - (Original_Node (Type_High_Bound (T)), Ent2, Kind2, Cons2); - - if Present (Ent1) - and then Ent1 = Ent2 - and then Kind1 = Kind2 - then - Len := Cons2 - Cons1 + 1; - else - Len := Uint_Minus_1; - end if; - end Extract_Length; - end Get_Static_Length; + Left_Typ : constant Entity_Id := Etype (Left); + Right_Typ : constant Entity_Id := Etype (Right); + Fold : Boolean; + Left_Len : Uint; + Op_Typ : Entity_Id := Empty; + Right_Len : Uint; + + Is_Static_Expression : Boolean; - -- Local Variables + -- Start of processing for Eval_Relational_Op + + begin + -- One special case to deal with first. If we can tell that the result + -- will be false because the lengths of one or more index subtypes are + -- compile time known and different, then we can replace the entire + -- result by False. We only do this for one dimensional arrays, because + -- the case of multi-dimensional arrays is rare and too much trouble. If + -- one of the operands is an illegal aggregate, its type might still be + -- an arbitrary composite type, so nothing to do. - Len_L : Uint; - Len_R : Uint; + if Is_Array_Type (Left_Typ) + and then Left_Typ /= Any_Composite + and then Number_Dimensions (Left_Typ) = 1 + and then Nkind_In (N, N_Op_Eq, N_Op_Ne) + then + if Raises_Constraint_Error (Left) + or else + Raises_Constraint_Error (Right) + then + return; - -- Start of processing for Length_Mismatch + -- OK, we have the case where we may be able to do this fold - begin - Get_Static_Length (Left, Len_L); - Get_Static_Length (Right, Len_R); + else + Left_Len := Static_Length (Left); + Right_Len := Static_Length (Right); - if Len_L /= Uint_Minus_1 - and then Len_R /= Uint_Minus_1 - and then Len_L /= Len_R + if Left_Len /= Uint_Minus_1 + and then Right_Len /= Uint_Minus_1 + and then Left_Len /= Right_Len then Fold_Uint (N, Test (Nkind (N) = N_Op_Ne), False); Warn_On_Known_Condition (N); return; end if; - end Length_Mismatch; - end if; - - declare - Is_Static_Expression : Boolean; + end if; - Is_Foldable : Boolean; - pragma Unreferenced (Is_Foldable); + -- General case - begin - -- Initialize the value of Is_Static_Expression. The value of - -- Is_Foldable returned by Test_Expression_Is_Foldable is not needed - -- since, even when some operand is a variable, we can still perform - -- the static evaluation of the expression in some cases (for - -- example, for a variable of a subtype of Integer we statically - -- know that any value stored in such variable is smaller than - -- Integer'Last). + else + -- Initialize the value of Is_Static_Expression. The value of Fold + -- returned by Test_Expression_Is_Foldable is not needed since, even + -- when some operand is a variable, we can still perform the static + -- evaluation of the expression in some cases (for example, for a + -- variable of a subtype of Integer we statically know that any value + -- stored in such variable is smaller than Integer'Last). Test_Expression_Is_Foldable - (N, Left, Right, Is_Static_Expression, Is_Foldable); + (N, Left, Right, Is_Static_Expression, Fold); - -- Only comparisons of scalars can give static results. In - -- particular, comparisons of strings never yield a static - -- result, even if both operands are static strings, except that - -- as noted above, we allow equality/inequality for strings. + -- Only comparisons of scalars can give static results. A comparison + -- of strings never yields a static result, even if both operands are + -- static strings, except that as noted above, we allow equality and + -- inequality for strings. - if Is_String_Type (Typ) + if Is_String_Type (Left_Typ) and then not Comes_From_Source (N) and then Nkind_In (N, N_Op_Eq, N_Op_Ne) then null; - elsif not Is_Scalar_Type (Typ) then + elsif not Is_Scalar_Type (Left_Typ) then Is_Static_Expression := False; Set_Is_Static_Expression (N, False); end if; @@ -3420,117 +3510,27 @@ package body Sem_Eval is -- an explicit scope, determine appropriate specific numeric type, -- and diagnose possible ambiguity. - if Is_Universal_Numeric_Type (Etype (Left)) + if Is_Universal_Numeric_Type (Left_Typ) and then - Is_Universal_Numeric_Type (Etype (Right)) + Is_Universal_Numeric_Type (Right_Typ) then - Otype := Find_Universal_Operator_Type (N); + Op_Typ := Find_Universal_Operator_Type (N); end if; - -- For static real type expressions, do not use Compile_Time_Compare - -- since it worries about run-time results which are not exact. - - if Is_Static_Expression and then Is_Real_Type (Typ) then - declare - Left_Real : constant Ureal := Expr_Value_R (Left); - Right_Real : constant Ureal := Expr_Value_R (Right); - - begin - case Nkind (N) is - when N_Op_Eq => Result := (Left_Real = Right_Real); - when N_Op_Ne => Result := (Left_Real /= Right_Real); - when N_Op_Lt => Result := (Left_Real < Right_Real); - when N_Op_Le => Result := (Left_Real <= Right_Real); - when N_Op_Gt => Result := (Left_Real > Right_Real); - when N_Op_Ge => Result := (Left_Real >= Right_Real); - when others => raise Program_Error; - end case; - - Fold_Uint (N, Test (Result), True); - end; - - -- For all other cases, we use Compile_Time_Compare to do the compare + -- Attempt to fold the relational operator + if Is_Static_Expression and then Is_Real_Type (Left_Typ) then + Fold_Static_Real_Op; else - declare - CR : constant Compare_Result := - Compile_Time_Compare - (Left, Right, Assume_Valid => False); - - begin - if CR = Unknown then - return; - end if; - - case Nkind (N) is - when N_Op_Eq => - if CR = EQ then - Result := True; - elsif CR = NE or else CR = GT or else CR = LT then - Result := False; - else - return; - end if; - - when N_Op_Ne => - if CR = NE or else CR = GT or else CR = LT then - Result := True; - elsif CR = EQ then - Result := False; - else - return; - end if; - - when N_Op_Lt => - if CR = LT then - Result := True; - elsif CR = EQ or else CR = GT or else CR = GE then - Result := False; - else - return; - end if; - - when N_Op_Le => - if CR = LT or else CR = EQ or else CR = LE then - Result := True; - elsif CR = GT then - Result := False; - else - return; - end if; - - when N_Op_Gt => - if CR = GT then - Result := True; - elsif CR = EQ or else CR = LT or else CR = LE then - Result := False; - else - return; - end if; - - when N_Op_Ge => - if CR = GT or else CR = EQ or else CR = GE then - Result := True; - elsif CR = LT then - Result := False; - else - return; - end if; - - when others => - raise Program_Error; - end case; - end; - - Fold_Uint (N, Test (Result), Is_Static_Expression); + Fold_General_Op (Is_Static_Expression); end if; - end; + end if; -- For the case of a folded relational operator on a specific numeric - -- type, freeze operand type now. + -- type, freeze the operand type now. - if Present (Otype) then - Freeze_Before (N, Otype); + if Present (Op_Typ) then + Freeze_Before (N, Op_Typ); end if; Warn_On_Known_Condition (N); @@ -6053,6 +6053,85 @@ package body Sem_Eval is end if; end Test; + --------------------- + -- Test_Comparison -- + --------------------- + + procedure Test_Comparison + (Op : Node_Id; + Assume_Valid : Boolean; + True_Result : out Boolean; + False_Result : out Boolean) + is + Left : constant Node_Id := Left_Opnd (Op); + Left_Typ : constant Entity_Id := Etype (Left); + Orig_Op : constant Node_Id := Original_Node (Op); + + procedure Replacement_Warning (Msg : String); + -- Emit a warning on a comparison which can be replaced by '=' + + ------------------------- + -- Replacement_Warning -- + ------------------------- + + procedure Replacement_Warning (Msg : String) is + begin + if Constant_Condition_Warnings + and then Comes_From_Source (Orig_Op) + and then Is_Integer_Type (Left_Typ) + and then not Error_Posted (Op) + and then not Has_Warnings_Off (Left_Typ) + and then not In_Instance + then + Error_Msg_N (Msg, Op); + end if; + end Replacement_Warning; + + -- Local variables + + Res : constant Compare_Result := + Compile_Time_Compare (Left, Right_Opnd (Op), Assume_Valid); + + -- Start of processing for Test_Comparison + + begin + case N_Op_Compare (Nkind (Op)) is + when N_Op_Eq => + True_Result := Res = EQ; + False_Result := Res = LT or else Res = GT or else Res = NE; + + when N_Op_Ge => + True_Result := Res in Compare_GE; + False_Result := Res = LT; + + if Res = LE and then Nkind (Orig_Op) = N_Op_Ge then + Replacement_Warning + ("can never be greater than, could replace by ""'=""?c?"); + end if; + + when N_Op_Gt => + True_Result := Res = GT; + False_Result := Res in Compare_LE; + + when N_Op_Le => + True_Result := Res in Compare_LE; + False_Result := Res = GT; + + if Res = GE and then Nkind (Orig_Op) = N_Op_Le then + Replacement_Warning + ("can never be less than, could replace by ""'=""?c?"); + end if; + + when N_Op_Lt => + True_Result := Res = LT; + False_Result := Res in Compare_GE; + + when N_Op_Ne => + True_Result := Res = NE or else Res = GT or else Res = LT; + False_Result := Res = EQ; + end case; + end Test_Comparison; + --------------------------------- -- Test_Expression_Is_Foldable -- --------------------------------- diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads index b689b80011d..75d9d796ea0 100644 --- a/gcc/ada/sem_eval.ads +++ b/gcc/ada/sem_eval.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2015, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -508,6 +508,16 @@ package Sem_Eval is -- except when testing a generic actual T1 against an ancestor T2 in a -- formal derived type association (indicated by Formal_Derived_Matching). + procedure Test_Comparison + (Op : Node_Id; + Assume_Valid : Boolean; + True_Result : out Boolean; + False_Result : out Boolean); + -- Determine the outcome of evaluating comparison operator Op using routine + -- Compile_Time_Compare. Assume_Valid should be set when the operands are + -- to be assumed valid. Flags True_Result and False_Result are set when the + -- comparison evaluates to True or False respectively. + procedure Why_Not_Static (Expr : Node_Id); -- This procedure may be called after generating an error message that -- complains that something is non-static. If it finds good reasons, it diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 6e8032c855c..e6511f437f3 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -141,6 +141,12 @@ package body Sem_Warn is -- a body formal, the setting of the flag in the corresponding spec is -- also checked (and True returned if either flag is True). + function Is_Attribute_And_Known_Value_Comparison + (Op : Node_Id) return Boolean; + -- Determine whether operator Op denotes a comparison where the left + -- operand is an attribute reference and the value of the right operand is + -- known at compile time. + function Never_Set_In_Source_Check_Spec (E : Entity_Id) return Boolean; -- Tests Never_Set_In_Source status for entity E. If E is not a formal, -- this is simply the setting of the flag Never_Set_In_Source. If E is @@ -2840,6 +2846,23 @@ package body Sem_Warn is In_Out_Warnings.Init; end Initialize; + --------------------------------------------- + -- Is_Attribute_And_Known_Value_Comparison -- + --------------------------------------------- + + function Is_Attribute_And_Known_Value_Comparison + (Op : Node_Id) return Boolean + is + Orig_Op : constant Node_Id := Original_Node (Op); + + begin + return + Nkind (Orig_Op) in N_Op_Compare + and then Nkind (Original_Node (Left_Opnd (Orig_Op))) = + N_Attribute_Reference + and then Compile_Time_Known_Value (Right_Opnd (Orig_Op)); + end Is_Attribute_And_Known_Value_Comparison; + ------------------------------------ -- Never_Set_In_Source_Check_Spec -- ------------------------------------ @@ -3239,13 +3262,55 @@ package body Sem_Warn is end if; end Referenced_As_Out_Parameter_Check_Spec; + -------------------------------------- + -- Warn_On_Constant_Valid_Condition -- + -------------------------------------- + + procedure Warn_On_Constant_Valid_Condition (Op : Node_Id) is + True_Result : Boolean; + False_Result : Boolean; + + begin + -- Determine the potential outcome of the comparison assuming that the + -- operands are valid. Do not consider instances because the check was + -- already performed in the generic. Do not consider comparison between + -- an attribute reference and a compile time known value since this is + -- most likely a conditional compilation. Do not consider internal files + -- in order to allow for various assertions and safeguards within our + -- runtime. + + if Constant_Condition_Warnings + and then Comes_From_Source (Original_Node (Op)) + and then not In_Instance + and then not Is_Attribute_And_Known_Value_Comparison (Op) + and then not Is_Internal_File_Name + (Unit_File_Name (Get_Source_Unit (Op))) + then + Test_Comparison + (Op => Op, + Assume_Valid => True, + True_Result => True_Result, + False_Result => False_Result); + + -- Warn on a possible evaluation to False / True in the presence of + -- invalid values. + + if True_Result then + Error_Msg_N + ("condition can only be False if invalid values present??", Op); + + elsif False_Result then + Error_Msg_N + ("condition can only be True if invalid values present??", Op); + end if; + end if; + end Warn_On_Constant_Valid_Condition; + ----------------------------- -- Warn_On_Known_Condition -- ----------------------------- procedure Warn_On_Known_Condition (C : Node_Id) is - P : Node_Id; - Orig : constant Node_Id := Original_Node (C); Test_Result : Boolean; function Is_Known_Branch return Boolean; @@ -3327,6 +3392,11 @@ package body Sem_Warn is end if; end Track; + -- Local variables + + Orig : constant Node_Id := Original_Node (C); + P : Node_Id; + -- Start of processing for Warn_On_Known_Condition begin @@ -3365,11 +3435,7 @@ package body Sem_Warn is -- Don't warn if comparison of result of attribute against a constant -- value, since this is likely legitimate conditional compilation. - if Nkind (Orig) in N_Op_Compare - and then Compile_Time_Known_Value (Right_Opnd (Orig)) - and then Nkind (Original_Node (Left_Opnd (Orig))) = - N_Attribute_Reference - then + if Is_Attribute_And_Known_Value_Comparison (C) then return; end if; diff --git a/gcc/ada/sem_warn.ads b/gcc/ada/sem_warn.ads index cd71e3466b8..98f33875d15 100644 --- a/gcc/ada/sem_warn.ads +++ b/gcc/ada/sem_warn.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1999-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -168,6 +168,11 @@ package Sem_Warn is -- code has a test that explicitly checks P'First, then it is not operating -- in blind assumption mode). + procedure Warn_On_Constant_Valid_Condition (Op : Node_Id); + -- Determine the outcome of evaluating conditional or relational operator + -- Op assuming that its operands are valid. Emit a warning when the result + -- of the evaluation is True or False. + procedure Warn_On_Known_Condition (C : Node_Id); -- C is a node for a boolean expression resulting from a relational -- or membership operation. If the expression has a compile time known diff --git a/gcc/ada/sinfo.ads b/gcc/ada/sinfo.ads index ae884e08bbd..6b77dccb0c9 100644 --- a/gcc/ada/sinfo.ads +++ b/gcc/ada/sinfo.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -9358,6 +9358,7 @@ package Sinfo is function Generalized_Indexing (N : Node_Id) return Node_Id; -- Node4 + function Generic_Associations (N : Node_Id) return List_Id; -- List3 diff --git a/gcc/ada/urealp.adb b/gcc/ada/urealp.adb index 235a10d54fc..5aaee7d13fe 100644 --- a/gcc/ada/urealp.adb +++ b/gcc/ada/urealp.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -493,7 +493,14 @@ package body Urealp is procedure Tree_Read is begin + -- Disable the warnings emitted by -gnatwc because the following check + -- acts as a signal in case Num_Ureal_Constants is changed. + + pragma Warnings + (Off, "condition can only be * if invalid values present"); pragma Assert (Num_Ureal_Constants = 10); + pragma Warnings + (On, "condition can only be * if invalid values present"); Ureals.Tree_Read; Tree_Read_Int (Int (UR_0)); @@ -518,7 +525,14 @@ package body Urealp is procedure Tree_Write is begin + -- Disable the warnings emitted by -gnatwc because the following check + -- acts as a signal in case Num_Ureal_Constants is changed. + + pragma Warnings + (Off, "condition can only be * if invalid values present"); pragma Assert (Num_Ureal_Constants = 10); + pragma Warnings + (On, "condition can only be * if invalid values present"); Ureals.Tree_Write; Tree_Write_Int (Int (UR_0)); diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index b0f7de19250..8a47fd642d0 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1992-2016, Free Software Foundation, Inc. -- +-- Copyright (C) 1992-2017, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- @@ -671,7 +671,13 @@ begin Write_Switch_Char ("zr"); Write_Line ("Distribution stub generation for receiver stubs"); + -- Disable the warnings emitted by -gnatwc because Ada_Version_Default may + -- be changed to denote a different default value. + + pragma Warnings (Off, "condition can only be * if invalid values present"); + if not Latest_Ada_Only then + -- Line for -gnat83 switch Write_Switch_Char ("83"); @@ -708,6 +714,8 @@ begin Write_Line ("Ada 2012 mode"); end if; + pragma Warnings (On, "condition can only be * if invalid values present"); + -- Line for -gnat-p switch Write_Switch_Char ("-p"); -- 2.30.2