Skip to content

R
riscv-gcc-1
Commit 36fcf362 by Robert Dewar Committed by Arnaud Charlet
Options

exp_prag.adb (Expand_Pragma_Assert): Recognize new warning flag for assert fail 

2007-12-06  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* 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
parent c8b92217
Showing with 125 additions and 33 deletions
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
......
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 <condition> 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));
......
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
......
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");
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment