diff options
Diffstat (limited to 'gcc/ada/sem_warn.adb')
| -rw-r--r-- | gcc/ada/sem_warn.adb | 321 |
1 files changed, 167 insertions, 154 deletions
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb index 04e7acf..b67bb7d 100644 --- a/gcc/ada/sem_warn.adb +++ b/gcc/ada/sem_warn.adb @@ -6,7 +6,7 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1999-2019, Free Software Foundation, Inc. -- +-- Copyright (C) 1999-2020, 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- -- @@ -1165,7 +1165,7 @@ package body Sem_Warn is if Ekind (E1) = E_Variable or else - (Ekind_In (E1, E_Out_Parameter, E_In_Out_Parameter) + (Ekind (E1) in E_Out_Parameter | E_In_Out_Parameter and then not Is_Protected_Type (Current_Scope)) then -- If the formal has a class-wide type, retrieve its type @@ -1469,9 +1469,9 @@ package body Sem_Warn is UR := Original_Node (UR); loop - if Nkind_In (UR, N_Expression_With_Actions, - N_Qualified_Expression, - N_Type_Conversion) + if Nkind (UR) in N_Expression_With_Actions + | N_Qualified_Expression + | N_Type_Conversion then UR := Expression (UR); @@ -1612,9 +1612,9 @@ package body Sem_Warn is and then (Is_Object (E1) or else Is_Type (E1) or else Ekind (E1) = E_Label - or else Ekind_In (E1, E_Exception, - E_Named_Integer, - E_Named_Real) + or else Ekind (E1) in E_Exception + | E_Named_Integer + | E_Named_Real or else Is_Overloadable (E1) -- Package case, if the main unit is a package spec @@ -1835,7 +1835,7 @@ package body Sem_Warn is elsif Nkind (Pref) = N_Explicit_Dereference then return True; - -- If prefix is itself a component reference or slice check prefix + -- If prefix is itself a component reference or slice check prefix elsif Nkind (Pref) = N_Slice or else Nkind (Pref) = N_Indexed_Component @@ -1872,7 +1872,7 @@ package body Sem_Warn is -- have a reference from generated code, it is bogus (e.g. calls to init -- procs to set default discriminant values). - if not Comes_From_Source (N) then + if not Comes_From_Source (Original_Node (N)) then return; end if; @@ -1895,7 +1895,7 @@ package body Sem_Warn is E : constant Entity_Id := Entity (N); begin - if Ekind_In (E, E_Variable, E_Out_Parameter) + if Ekind (E) in E_Variable | E_Out_Parameter and then Never_Set_In_Source_Check_Spec (E) and then not Has_Initial_Value (E) and then (No (Unset_Reference (E)) @@ -1975,10 +1975,11 @@ package body Sem_Warn is Nod := Parent (N); while Present (Nod) loop if Nkind (Nod) = N_Pragma - and then Nam_In (Pragma_Name_Unmapped (Nod), - Name_Postcondition, - Name_Refined_Post, - Name_Contract_Cases) + and then + Pragma_Name_Unmapped (Nod) + in Name_Postcondition + | Name_Refined_Post + | Name_Contract_Cases then return True; @@ -2102,7 +2103,7 @@ package body Sem_Warn is P := Parent (P); exit when No (P); - if Nkind_In (P, N_If_Statement, N_Elsif_Part) + if Nkind (P) in N_If_Statement | N_Elsif_Part and then Ref_In (Condition (P)) then return; @@ -2993,6 +2994,13 @@ package body Sem_Warn is exception when others => + -- With debug flag K we will get an exception unless an error has + -- already occurred (useful for debugging). + + if Debug_Flag_K then + Check_Error_Detected; + end if; + return False; end Operand_Has_Warnings_Suppressed; @@ -3181,7 +3189,7 @@ package body Sem_Warn is -- Reference to obsolescent component - elsif Ekind_In (E, E_Component, E_Discriminant) then + elsif Ekind (E) in E_Component | E_Discriminant then Error_Msg_NE ("??reference to obsolescent component& declared#", N, E); @@ -3386,11 +3394,11 @@ package body Sem_Warn is if True_Result then Error_Msg_N - ("condition can only be False if invalid values present??", Op); + ("condition can only be False if invalid values present?c?", Op); elsif False_Result then Error_Msg_N - ("condition can only be True if invalid values present??", Op); + ("condition can only be True if invalid values present?c?", Op); end if; end if; end Warn_On_Constant_Valid_Condition; @@ -3520,6 +3528,7 @@ package body Sem_Warn is if Constant_Condition_Warnings and then Is_Known_Branch and then Comes_From_Source (Orig) + and then Nkind (Orig) in N_Has_Entity and then not In_Instance then -- Don't warn if comparison of result of attribute against a constant @@ -3559,8 +3568,9 @@ package body Sem_Warn is -- node, since assert pragmas get rewritten at analysis time. elsif Nkind (Original_Node (P)) = N_Pragma - and then Nam_In (Pragma_Name_Unmapped (Original_Node (P)), - Name_Assert, Name_Check) + and then + Pragma_Name_Unmapped (Original_Node (P)) + in Name_Assert | Name_Check then return; end if; @@ -3643,9 +3653,6 @@ package body Sem_Warn is --------------------------------- procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is - function Is_Covered_Formal (Formal : Node_Id) return Boolean; - -- Return True if Formal is covered by the rule - function Refer_Same_Object (Act1 : Node_Id; Act2 : Node_Id) return Boolean; @@ -3658,19 +3665,6 @@ package body Sem_Warn is -- (RM 6.4.1(6.11/3)) ----------------------- - -- Is_Covered_Formal -- - ----------------------- - - function Is_Covered_Formal (Formal : Node_Id) return Boolean is - begin - return - Ekind_In (Formal, E_Out_Parameter, E_In_Out_Parameter) - and then (Is_Elementary_Type (Etype (Formal)) - or else Is_Record_Type (Etype (Formal)) - or else Is_Array_Type (Etype (Formal))); - end Is_Covered_Formal; - - ----------------------- -- Refer_Same_Object -- ----------------------- @@ -3690,9 +3684,6 @@ package body Sem_Warn is Act2 : Node_Id; Form1 : Entity_Id; Form2 : Entity_Id; - Warn_Only : Boolean; - -- GNAT warns on overlapping in-out parameters of any type, not just for - -- elementary in-out parameters (as specified in RM 6.4.1 (15/3-17/3)). -- Start of processing for Warn_On_Overlapping_Actuals @@ -3702,29 +3693,6 @@ package body Sem_Warn is return; end if; - -- The call is illegal only if there are at least two in-out parameters - -- of the same elementary type. - - Warn_Only := True; - Form1 := First_Formal (Subp); - while Present (Form1) loop - Form2 := Next_Formal (Form1); - while Present (Form2) loop - if Is_Elementary_Type (Etype (Form1)) - and then Is_Elementary_Type (Etype (Form2)) - and then Ekind (Form1) /= E_In_Parameter - and then Ekind (Form2) /= E_In_Parameter - then - Warn_Only := False; - exit; - end if; - - Next_Formal (Form2); - end loop; - - Next_Formal (Form1); - end loop; - -- Exclude calls rewritten as enumeration literals if Nkind (N) not in N_Subprogram_Call @@ -3738,91 +3706,137 @@ package body Sem_Warn is -- N that is passed as a parameter of mode in out or out to the call C, -- there is no other name among the other parameters of mode in out or -- out to C that is known to denote the same object (RM 6.4.1(6.15/3)) + -- This has been clarified in AI12-0216 to indicate that the illegality + -- only occurs if both formals are of an elementary type, because of the + -- nondeterminism on the write-back of the corresponding actuals. + -- Earlier versions of the language made it illegal if only one of the + -- actuals was an elementary parameter that overlapped a composite + -- actual, and both were writable. -- If appropriate warning switch is set, we also report warnings on - -- overlapping parameters that are record types or array types. + -- overlapping parameters that are composite types. Users find these + -- warnings useful, and they are used in style guides. + + -- It is also worthwhile to warn on overlaps of composite objects when + -- only one of the formals is (in)-out. Note that the RM rule above is + -- a legality rule. We choose to implement this check as a warning to + -- avoid major incompatibilities with legacy code. + + -- Note also that the rule in 6.4.1 (6.17/3), introduced by AI12-0324, + -- is potentially more expensive to verify, and is not yet implemented. Form1 := First_Formal (Subp); Act1 := First_Actual (N); while Present (Form1) and then Present (Act1) loop - if Is_Covered_Formal (Form1) then - Form2 := First_Formal (Subp); - Act2 := First_Actual (N); + if Is_Generic_Type (Etype (Act1)) then + return; + end if; + + -- One of the formals must be either (in)-out or composite. + -- The other must be (in)-out. + + if Is_Elementary_Type (Etype (Act1)) + and then Ekind (Form1) = E_In_Parameter + then + null; + + else + Form2 := Next_Formal (Form1); + Act2 := Next_Actual (Act1); while Present (Form2) and then Present (Act2) loop - if Form1 /= Form2 - and then Is_Covered_Formal (Form2) - and then Refer_Same_Object (Act1, Act2) - then - -- Guard against previous errors + if Refer_Same_Object (Act1, Act2) then + if Is_Generic_Type (Etype (Act2)) then + return; + end if; - if Error_Posted (N) - or else No (Etype (Act1)) - or else No (Etype (Act2)) - then - null; + -- First case : two writable elementary parameters + -- that overlap. - -- If the actual is a function call in prefix notation, - -- there is no real overlap. + if (Is_Elementary_Type (Etype (Form1)) + and then Is_Elementary_Type (Etype (Form2)) + and then Ekind (Form1) /= E_In_Parameter + and then Ekind (Form2) /= E_In_Parameter) - elsif Nkind (Act2) = N_Function_Call then - null; + -- Second case : two composite parameters that overlap, + -- one of which is writable. - -- If type is not by-copy, assume that aliasing is intended + or else (Is_Composite_Type (Etype (Form1)) + and then Is_Composite_Type (Etype (Form2)) + and then (Ekind (Form1) /= E_In_Parameter + or else Ekind (Form2) /= E_In_Parameter)) - elsif - Present (Underlying_Type (Etype (Form1))) - and then - (Is_By_Reference_Type (Underlying_Type (Etype (Form1))) - or else - Convention (Underlying_Type (Etype (Form1))) = - Convention_Ada_Pass_By_Reference) - then - null; + -- Third case : an elementary writable parameter that + -- overlaps a composite one. - -- Under Ada 2012 we only report warnings on overlapping - -- arrays and record types if switch is set. + or else (Is_Elementary_Type (Etype (Form1)) + and then Ekind (Form1) /= E_In_Parameter + and then Is_Composite_Type (Etype (Form2))) - elsif Ada_Version >= Ada_2012 - and then not Is_Elementary_Type (Etype (Form1)) - and then not Warn_On_Overlap + or else (Is_Elementary_Type (Etype (Form2)) + and then Ekind (Form2) /= E_In_Parameter + and then Is_Composite_Type (Etype (Form1))) then - null; - -- Here we may need to issue overlap message + -- Guard against previous errors - else - Error_Msg_Warn := + if Error_Posted (N) + or else No (Etype (Act1)) + or else No (Etype (Act2)) + then + null; - -- Overlap checking is an error only in Ada 2012. For - -- earlier versions of Ada, this is a warning. + -- If the actual is a function call in prefix notation, + -- there is no real overlap. - Ada_Version < Ada_2012 + elsif Nkind (Act2) = N_Function_Call then + null; - -- Overlap is only illegal in Ada 2012 in the case of - -- elementary types (passed by copy). For other types, - -- we always have a warning in all Ada versions. + -- If type is explicitly not by-copy, assume that + -- aliasing is intended. + + elsif + Present (Underlying_Type (Etype (Form1))) + and then + (Is_By_Reference_Type + (Underlying_Type (Etype (Form1))) + or else + Convention (Underlying_Type (Etype (Form1))) = + Convention_Ada_Pass_By_Reference) + then + null; - or else not Is_Elementary_Type (Etype (Form1)) + -- Under Ada 2012 we only report warnings on overlapping + -- arrays and record types if switch is set. - -- debug flag -gnatd.E changes the error to a warning - -- even in Ada 2012 mode. + elsif Ada_Version >= Ada_2012 + and then not Is_Elementary_Type (Etype (Form1)) + and then not Warn_On_Overlap + then + null; - or else Error_To_Warning - or else Warn_Only; + -- Here we may need to issue overlap message - declare - Act : Node_Id; - Form : Entity_Id; + else + Error_Msg_Warn := - begin - -- Find matching actual + -- Overlap checking is an error only in Ada 2012. + -- For earlier versions of Ada, this is a warning. - Act := First_Actual (N); - Form := First_Formal (Subp); - while Act /= Act2 loop - Next_Formal (Form); - Next_Actual (Act); - end loop; + Ada_Version < Ada_2012 + + -- Overlap is only illegal in Ada 2012 in the case + -- of elementary types (passed by copy). For other + -- types we always have a warning in all versions. + -- This is clarified by AI12-0216. + + or else not + (Is_Elementary_Type (Etype (Form1)) + and then Is_Elementary_Type (Etype (Form2))) + + -- debug flag -gnatd.E changes the error to a + -- warning even in Ada 2012 mode. + + or else Error_To_Warning; if Is_Elementary_Type (Etype (Act1)) and then Ekind (Form2) = E_In_Parameter @@ -3836,12 +3850,12 @@ package body Sem_Warn is -- If the call was written in prefix notation, and -- thus its prefix before rewriting was a selected - -- component, count only visible actuals in the call. + -- component, count only visible actuals in call. elsif Is_Entity_Name (First_Actual (N)) and then Nkind (Original_Node (N)) = Nkind (N) and then Nkind (Name (Original_Node (N))) = - N_Selected_Component + N_Selected_Component and then Is_Entity_Name (Prefix (Name (Original_Node (N)))) and then @@ -3850,30 +3864,30 @@ package body Sem_Warn is then if Act1 = First_Actual (N) then Error_Msg_FE - ("<<`IN OUT` prefix overlaps with " - & "actual for&", Act1, Form); + ("<I<`IN OUT` prefix overlaps with " + & "actual for&", Act1, Form2); else -- For greater clarity, give name of formal - Error_Msg_Node_2 := Form; + Error_Msg_Node_2 := Form2; Error_Msg_FE - ("<<writable actual for & overlaps with " - & "actual for&", Act1, Form); + ("<I<writable actual for & overlaps with " + & "actual for&", Act1, Form2); end if; else -- For greater clarity, give name of formal - Error_Msg_Node_2 := Form; + Error_Msg_Node_2 := Form2; -- This is one of the messages Error_Msg_FE - ("<<writable actual for & overlaps with " + ("<I<writable actual for & overlaps with " & "actual for&", Act1, Form1); end if; - end; + end if; end if; return; @@ -4220,7 +4234,7 @@ package body Sem_Warn is -- Only process if warnings activated if Warn_On_Suspicious_Contract then - if Nkind_In (Par, N_Op_Eq, N_Op_Ne) then + if Nkind (Par) in N_Op_Eq | N_Op_Ne then if N = Left_Opnd (Par) then Arg := Right_Opnd (Par); else @@ -4330,11 +4344,10 @@ package body Sem_Warn is -- the message if the variable is volatile, has an address -- clause, is aliased, or is a renaming, or is imported. - if Referenced_As_LHS_Check_Spec (E) - and then No (Address_Clause (E)) - and then not Is_Volatile (E) - then + if Referenced_As_LHS_Check_Spec (E) then if Warn_On_Modified_Unread + and then No (Address_Clause (E)) + and then not Is_Volatile (E) and then not Is_Imported (E) and then not Is_Aliased (E) and then No (Renamed_Object (E)) @@ -4411,10 +4424,10 @@ package body Sem_Warn is B : constant Node_Id := Parent (Parent (Scope (E))); S : Entity_Id := Empty; begin - if Nkind_In (B, - N_Expression_Function, - N_Subprogram_Body, - N_Subprogram_Renaming_Declaration) + if Nkind (B) in + N_Expression_Function | + N_Subprogram_Body | + N_Subprogram_Renaming_Declaration then S := Corresponding_Spec (B); end if; @@ -4576,10 +4589,10 @@ package body Sem_Warn is -- When we hit a package/subprogram body, issue warning and exit - elsif Nkind_In (P, N_Entry_Body, - N_Package_Body, - N_Subprogram_Body, - N_Task_Body) + elsif Nkind (P) in N_Entry_Body + | N_Package_Body + | N_Subprogram_Body + | N_Task_Body then -- Case of assigned value never referenced @@ -4603,8 +4616,8 @@ package body Sem_Warn is -- Give appropriate message, distinguishing between -- assignment statements and out parameters. - if Nkind_In (Parent (LA), N_Parameter_Association, - N_Procedure_Call_Statement) + if Nkind (Parent (LA)) in N_Parameter_Association + | N_Procedure_Call_Statement then Error_Msg_NE ("?m?& modified by call, but value might not be " @@ -4630,8 +4643,8 @@ package body Sem_Warn is -- Give appropriate message, distinguishing between -- assignment statements and out parameters. - if Nkind_In (Parent (LA), N_Procedure_Call_Statement, - N_Parameter_Association) + if Nkind (Parent (LA)) in N_Procedure_Call_Statement + | N_Parameter_Association then Error_Msg_NE ("?m?& modified by call, but value overwritten #!", @@ -4662,10 +4675,10 @@ package body Sem_Warn is -- not generate the warning, since the variable in question -- may be accessed after an exception in the outer block. - if not Nkind_In (Parent (P), N_Entry_Body, - N_Package_Body, - N_Subprogram_Body, - N_Task_Body) + if Nkind (Parent (P)) not in N_Entry_Body + | N_Package_Body + | N_Subprogram_Body + | N_Task_Body then Set_Last_Assignment (Ent, Empty); return; @@ -4690,7 +4703,7 @@ package body Sem_Warn is return; end if; - X := Next (X); + Next (X); end loop; end if; end if; |