From 36fcf362ce30d24b353f5ece90fb8d760af8626c Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Thu, 13 Dec 2007 11:26:56 +0100 Subject: [PATCH] exp_prag.adb (Expand_Pragma_Assert): Recognize new warning flag for assert fail 2007-12-06 Robert Dewar Ed Schonberg * exp_prag.adb (Expand_Pragma_Assert): Recognize new warning flag for assert fail * ug_words: Add entries for -gnatw.a -gnatw.A * sem_res.adb (Set_String_Literal_Subtype): If the context of the literal is a subtype with non-static constraints, use the base type of the context as the base of the string subtype, to prevent type mismatches in gigi. (Resolve_Actuals): If the actual is an entity name, generate a reference before the actual is resolved and expanded, to prevent spurious warnings on formals of enclosing protected operations. (Analyze_Overloaded_Selected_Component): If type of prefix if class-wide, use visible components of base type. (Resolve_Selected_Component): Ditto. (Resolve_Short_Circuit): Detect case of pragma Assert argument evaluating to False, and issue warning message. * usage.adb: Add lines for -gnatw.a and -gnatw.A From-SVN: r130838 --- gcc/ada/exp_prag.adb | 3 +- gcc/ada/sem_res.adb | 147 ++++++++++++++++++++++++++++++++++--------- gcc/ada/ug_words | 2 + gcc/ada/usage.adb | 6 +- 4 files changed, 125 insertions(+), 33 deletions(-) diff --git a/gcc/ada/exp_prag.adb b/gcc/ada/exp_prag.adb index 962dc7cc4287..27869a838271 100644 --- a/gcc/ada/exp_prag.adb +++ b/gcc/ada/exp_prag.adb @@ -323,7 +323,8 @@ package body Exp_Prag is -- If new condition is always false, give a warning - if Nkind (N) = N_Procedure_Call_Statement + if Warn_On_Assertion_Failure + and then Nkind (N) = N_Procedure_Call_Statement and then Is_RTE (Entity (Name (N)), RE_Raise_Assert_Failure) then -- If original condition was a Standard.False, we assume that this is diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 258064aa20d2..523a883ae452 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -2846,6 +2846,30 @@ package body Sem_Res is -- Case where actual is present + -- If the actual is an entity, generate a reference to it now. We + -- do this before the actual is resolved, because a formal of some + -- protected subprogram, or a task discriminant, will be rewritten + -- during expansion, and the reference to the source entity may + -- be lost. + + if Present (A) + and then Is_Entity_Name (A) + and then Comes_From_Source (N) + then + Orig_A := Entity (A); + + if Present (Orig_A) then + if Is_Formal (Orig_A) + and then Ekind (F) /= E_In_Parameter + then + Generate_Reference (Orig_A, A, 'm'); + + elsif not Is_Overloaded (A) then + Generate_Reference (Orig_A, A); + end if; + end if; + end if; + if Present (A) and then (Nkind (Parent (A)) /= N_Parameter_Association or else @@ -3043,43 +3067,38 @@ package body Sem_Res is end if; end if; - -- For IN parameter, this is where we generate a reference after - -- resolution is complete. - - if Ekind (F) = E_In_Parameter then - Orig_A := Original_Node (A); - - if Is_Entity_Name (Orig_A) - and then Present (Entity (Orig_A)) - then - Generate_Reference (Entity (Orig_A), Orig_A); - end if; - -- Case of OUT or IN OUT parameter - else - -- Validate the form of the actual. Note that the call to - -- Is_OK_Variable_For_Out_Formal generates the required - -- reference in this case. - - if not Is_OK_Variable_For_Out_Formal (A) then - Error_Msg_NE ("actual for& must be a variable", A, F); - end if; + if Ekind (F) /= E_In_Parameter then -- For an Out parameter, check for useless assignment. Note -- that we can't set Last_Assignment this early, because we -- may kill current values in Resolve_Call, and that call -- would clobber the Last_Assignment field. + -- Note: call Warn_On_Useless_Assignment before doing the + -- check below for Is_OK_Variable_For_Out_Formal so that the + -- setting of Referenced_As_LHS/Referenced_As_Out_Formal + -- properly reflects the last assignment, not this one! + if Ekind (F) = E_Out_Parameter then - if Warn_On_Out_Parameter_Unread + if Warn_On_Modified_As_Out_Parameter (F) and then Is_Entity_Name (A) and then Present (Entity (A)) + and then Comes_From_Source (N) then - Warn_On_Useless_Assignment (Entity (A), Sloc (A)); + Warn_On_Useless_Assignment (Entity (A), A); end if; end if; + -- Validate the form of the actual. Note that the call to + -- Is_OK_Variable_For_Out_Formal generates the required + -- reference in this case. + + if not Is_OK_Variable_For_Out_Formal (A) then + Error_Msg_NE ("actual for& must be a variable", A, F); + end if; + -- What's the following about??? if Is_Entity_Name (A) then @@ -4718,7 +4737,7 @@ package body Sem_Res is -- for it, precisely because we will not do it within the init proc -- itself. - -- If the subprogram is marked Inlined_Always, then even if it returns + -- If the subprogram is marked Inline_Always, then even if it returns -- an unconstrained type the call does not require use of the secondary -- stack. @@ -4809,12 +4828,12 @@ package body Sem_Res is Kill_Current_Values; end if; - -- If we are warning about unread out parameters, this is the place to - -- set Last_Assignment for out parameters. We have to do this after the - -- above call to Kill_Current_Values (since that call clears the - -- Last_Assignment field of all local variables). + -- If we are warning about unread OUT parameters, this is the place to + -- set Last_Assignment for OUT and IN OUT parameters. We have to do this + -- after the above call to Kill_Current_Values (since that call clears + -- the Last_Assignment field of all local variables). - if Warn_On_Out_Parameter_Unread + if (Warn_On_Modified_Unread or Warn_On_All_Unread_Out_Parameters) and then Comes_From_Source (N) and then In_Extended_Main_Source_Unit (N) then @@ -4826,9 +4845,12 @@ package body Sem_Res is F := First_Formal (Nam); A := First_Actual (N); while Present (F) and then Present (A) loop - if Ekind (F) = E_Out_Parameter + if (Ekind (F) = E_Out_Parameter + or else Ekind (F) = E_In_Out_Parameter) + and then Warn_On_Modified_As_Out_Parameter (F) and then Is_Entity_Name (A) and then Present (Entity (A)) + and then Comes_From_Source (N) and then Safe_To_Capture_Value (N, Entity (A)) then Set_Last_Assignment (Entity (A), A); @@ -6930,6 +6952,14 @@ package body Sem_Res is end if; if Is_Record_Type (T) then + + -- The visible components of a class-wide type are those of + -- the root type. + + if Is_Class_Wide_Type (T) then + T := Etype (T); + end if; + Comp := First_Entity (T); while Present (Comp) loop if Chars (Comp) = Chars (S) @@ -7090,6 +7120,58 @@ package body Sem_Res is Resolve (L, B_Typ); Resolve (R, B_Typ); + -- Check for issuing warning for always False assert, this happens + -- when assertions are turned off, in which case the pragma Assert + -- was transformed into: + + -- if False and then then ... + + -- and we detect this pattern + + if Warn_On_Assertion_Failure + and then Is_Entity_Name (R) + and then Entity (R) = Standard_False + and then Nkind (Parent (N)) = N_If_Statement + and then Nkind (N) = N_And_Then + and then Is_Entity_Name (L) + and then Entity (L) = Standard_False + then + declare + Orig : constant Node_Id := Original_Node (Parent (N)); + begin + if Nkind (Orig) = N_Pragma + and then Chars (Orig) = Name_Assert + then + -- Don't want to warn if original condition is explicit False + + declare + Expr : constant Node_Id := + Original_Node + (Expression + (First (Pragma_Argument_Associations (Orig)))); + begin + if Is_Entity_Name (Expr) + and then Entity (Expr) = Standard_False + then + null; + else + -- Issue warning. Note that we don't want to make this + -- an unconditional warning, because if the assert is + -- within deleted code we do not want the warning. But + -- we do not want the deletion of the IF/AND-THEN to + -- take this message with it. We achieve this by making + -- sure that the expanded code points to the Sloc of + -- the expression, not the original pragma. + + Error_Msg_N ("?assertion would fail at run-time", Orig); + end if; + end; + end if; + end; + end if; + + -- Continue with processing of short circuit + Check_Unset_Reference (L); Check_Unset_Reference (R); @@ -8232,7 +8314,12 @@ package body Sem_Res is Set_Parent (Drange, N); Analyze_And_Resolve (Drange, Index_Type); - Set_Etype (Index_Subtype, Index_Type); + -- In the context, the Index_Type may already have a constraint, + -- so use common base type on string subtype. The base type may + -- be used when generating attributes of the string, for example + -- in the context of a slice assignment. + + Set_Etype (Index_Subtype, Base_Type (Index_Type)); Set_Size_Info (Index_Subtype, Index_Type); Set_RM_Size (Index_Subtype, RM_Size (Index_Type)); diff --git a/gcc/ada/ug_words b/gcc/ada/ug_words index 2582b6360cc8..270289bd5f82 100644 --- a/gcc/ada/ug_words +++ b/gcc/ada/ug_words @@ -112,6 +112,8 @@ gcc -c ^ GNAT COMPILE -gnatw ^ /WARNINGS -gnatwa ^ /WARNINGS=OPTIONAL -gnatwA ^ /WARNINGS=NOOPTIONAL +-gnatw.a ^ /WARNINGS=FAILING_ASSERTIONS +-gnatw.A ^ /WARNINGS=NO_FAILING_ASSERTIONS -gnatwb ^ /WARNINGS=BAD_FIXED_VALUES -gnatwB ^ /WARNINGS=NO_BAD_FIXED_VALUES -gnatwc ^ /WARNINGS=CONDITIONALS diff --git a/gcc/ada/usage.adb b/gcc/ada/usage.adb index ae5ee42268b7..07735903f342 100644 --- a/gcc/ada/usage.adb +++ b/gcc/ada/usage.adb @@ -364,6 +364,8 @@ begin Write_Line ("Enable selected warning modes, xx = list of parameters:"); Write_Line (" a turn on all optional warnings (except d h l .o)"); Write_Line (" A turn off all optional warnings"); + Write_Line (" .a* turn on warnings for failing assertions"); + Write_Line (" .A turn off warnings for failing assertions"); Write_Line (" b turn on warnings for bad fixed value " & "(not multiple of small)"); Write_Line (" B* turn off warnings for bad fixed value " & @@ -400,9 +402,9 @@ begin Write_Line (" n* normal warning mode (cancels -gnatws/-gnatwe)"); Write_Line (" o* turn on warnings for address clause overlay"); Write_Line (" O turn off warnings for address clause overlay"); - Write_Line (" .o turn on warnings for out parameter assigned " & + Write_Line (" .o turn on warnings for out parameters assigned " & "but not read"); - Write_Line (" .O* turn off warnings for out parameter assigned " & + Write_Line (" .O* turn off warnings for out parameters assigned " & "but not read"); Write_Line (" p turn on warnings for ineffective pragma " & "Inline in frontend");