aboutsummaryrefslogtreecommitdiff
path: root/gcc/ada/sem_warn.adb
diff options
context:
space:
mode:
Diffstat (limited to 'gcc/ada/sem_warn.adb')
-rw-r--r--gcc/ada/sem_warn.adb343
1 files changed, 160 insertions, 183 deletions
diff --git a/gcc/ada/sem_warn.adb b/gcc/ada/sem_warn.adb
index b5275a8..9e337f9 100644
--- a/gcc/ada/sem_warn.adb
+++ b/gcc/ada/sem_warn.adb
@@ -6,7 +6,7 @@
-- --
-- B o d y --
-- --
--- Copyright (C) 1999-2020, Free Software Foundation, Inc. --
+-- Copyright (C) 1999-2021, 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- --
@@ -23,31 +23,35 @@
-- --
------------------------------------------------------------------------------
-with Atree; use Atree;
-with Debug; use Debug;
-with Einfo; use Einfo;
-with Errout; use Errout;
-with Exp_Code; use Exp_Code;
-with Lib; use Lib;
-with Lib.Xref; use Lib.Xref;
-with Namet; use Namet;
-with Nlists; use Nlists;
-with Opt; use Opt;
-with Par_SCO; use Par_SCO;
-with Rtsfind; use Rtsfind;
-with Sem; use Sem;
-with Sem_Ch8; use Sem_Ch8;
-with Sem_Aux; use Sem_Aux;
-with Sem_Eval; use Sem_Eval;
-with Sem_Prag; use Sem_Prag;
-with Sem_Util; use Sem_Util;
-with Sinfo; use Sinfo;
-with Sinput; use Sinput;
-with Snames; use Snames;
-with Stand; use Stand;
-with Stringt; use Stringt;
-with Tbuild; use Tbuild;
-with Uintp; use Uintp;
+with Atree; use Atree;
+with Debug; use Debug;
+with Einfo; use Einfo;
+with Einfo.Entities; use Einfo.Entities;
+with Einfo.Utils; use Einfo.Utils;
+with Errout; use Errout;
+with Exp_Code; use Exp_Code;
+with Lib; use Lib;
+with Lib.Xref; use Lib.Xref;
+with Namet; use Namet;
+with Nlists; use Nlists;
+with Opt; use Opt;
+with Par_SCO; use Par_SCO;
+with Rtsfind; use Rtsfind;
+with Sem; use Sem;
+with Sem_Ch8; use Sem_Ch8;
+with Sem_Aux; use Sem_Aux;
+with Sem_Eval; use Sem_Eval;
+with Sem_Prag; use Sem_Prag;
+with Sem_Util; use Sem_Util;
+with Sinfo; use Sinfo;
+with Sinfo.Nodes; use Sinfo.Nodes;
+with Sinfo.Utils; use Sinfo.Utils;
+with Sinput; use Sinput;
+with Snames; use Snames;
+with Stand; use Stand;
+with Stringt; use Stringt;
+with Tbuild; use Tbuild;
+with Uintp; use Uintp;
package body Sem_Warn is
@@ -1176,7 +1180,8 @@ package body Sem_Warn is
-- Case of an unassigned variable
-- First gather any Unset_Reference indication for E1. In the
- -- case of a parameter, it is the Spec_Entity that is relevant.
+ -- case of an 'out' parameter, it is the Spec_Entity that is
+ -- relevant.
if Ekind (E1) = E_Out_Parameter
and then Present (Spec_Entity (E1))
@@ -1215,8 +1220,8 @@ package body Sem_Warn is
-- the wanted effect is included in Never_Set_In_Source.
elsif Warn_On_Constant
- and then (Ekind (E1) = E_Variable
- and then Has_Initial_Value (E1))
+ and then Ekind (E1) = E_Variable
+ and then Has_Initial_Value (E1)
and then Never_Set_In_Source_Check_Spec (E1)
and then not Generic_Package_Spec_Entity (E1)
then
@@ -1294,9 +1299,9 @@ package body Sem_Warn is
-- never referenced, since again it seems odd to rely on
-- default initialization to set an out parameter value.
- and then (Is_Access_Type (E1T)
- or else Ekind (E1) = E_Out_Parameter
- or else not Is_Fully_Initialized_Type (E1T))
+ and then (Is_Access_Type (E1T)
+ or else Ekind (E1) = E_Out_Parameter
+ or else not Is_Fully_Initialized_Type (E1T))
then
-- Do not output complaint about never being assigned a
-- value if a pragma Unmodified applies to the variable
@@ -1350,9 +1355,11 @@ package body Sem_Warn is
-- Suppress warning if composite type contains any access
-- component, since the logical effect of modifying a
-- parameter may be achieved by modifying a referenced
- -- object.
+ -- object. This rationale does not apply to private
+ -- types, so we warn in that case.
elsif Is_Composite_Type (E1T)
+ and then not Is_Private_Type (E1T)
and then Has_Access_Values (E1T)
then
null;
@@ -1523,6 +1530,17 @@ package body Sem_Warn is
-- uninitialized component to get a better message.
elsif Nkind (Parent (UR)) = N_Selected_Component then
+ -- Suppress possibly superfluous warning if component
+ -- is known to exist and is partially initialized.
+
+ if not Has_Discriminants (Etype (E1))
+ and then
+ Is_Partially_Initialized_Type
+ (Etype (Parent (UR)), False)
+ then
+ goto Continue;
+ end if;
+
Error_Msg_Node_2 := Selector_Name (Parent (UR));
if not Comes_From_Source (Parent (UR)) then
@@ -2297,7 +2315,7 @@ package body Sem_Warn is
procedure Check_Inner_Package (Pack : Entity_Id) is
E : Entity_Id;
- Un : constant Node_Id := Sinfo.Unit (Cnode);
+ Un : constant Node_Id := Sinfo.Nodes.Unit (Cnode);
function Check_Use_Clause (N : Node_Id) return Traverse_Result;
-- If N is a use_clause for Pack, emit warning
@@ -3015,7 +3033,7 @@ package body Sem_Warn is
-- if we have seen the address of the subprogram being taken, or if the
-- subprogram is used as a generic actual (in the latter cases the
-- context may force use of IN OUT, even if the parameter is not
- -- modifies for this particular case.
+ -- modified for this particular case.
-----------------------
-- No_Warn_On_In_Out --
@@ -3075,7 +3093,7 @@ package body Sem_Warn is
-- Here we generate the warning
else
- -- If -gnatwk is set then output message that we could be IN
+ -- If -gnatwk is set then output message that it could be IN
if not Is_Trivial_Subprogram (Scope (E1)) then
if Warn_On_Constant then
@@ -3651,6 +3669,9 @@ package body Sem_Warn is
---------------------------------
procedure Warn_On_Overlapping_Actuals (Subp : Entity_Id; N : Node_Id) is
+ function Explicitly_By_Reference (Formal_Id : Entity_Id) return Boolean;
+ -- Returns True iff the type of Formal_Id is explicitly by-reference
+
function Refer_Same_Object
(Act1 : Node_Id;
Act2 : Node_Id) return Boolean;
@@ -3662,6 +3683,24 @@ package body Sem_Warn is
-- object_name is known to refer to the same object as the other name
-- (RM 6.4.1(6.11/3))
+ -----------------------------
+ -- Explicitly_By_Reference --
+ -----------------------------
+
+ function Explicitly_By_Reference
+ (Formal_Id : Entity_Id)
+ return Boolean
+ is
+ Typ : constant Entity_Id := Underlying_Type (Etype (Formal_Id));
+ begin
+ if Present (Typ) then
+ return Is_By_Reference_Type (Typ)
+ or else Convention (Typ) = Convention_Ada_Pass_By_Reference;
+ else
+ return False;
+ end if;
+ end Explicitly_By_Reference;
+
-----------------------
-- Refer_Same_Object --
-----------------------
@@ -3678,24 +3717,22 @@ package body Sem_Warn is
-- Local variables
- Act1 : Node_Id;
- Act2 : Node_Id;
- Form1 : Entity_Id;
- Form2 : Entity_Id;
+ Act1 : Node_Id;
+ Act2 : Node_Id;
+ Form1 : Entity_Id;
+ Form2 : Entity_Id;
-- Start of processing for Warn_On_Overlapping_Actuals
begin
+ -- Exclude calls rewritten as enumeration literals
- if Ada_Version < Ada_2012 and then not Warn_On_Overlap then
+ if Nkind (N) not in N_Subprogram_Call | N_Entry_Call_Statement then
return;
- end if;
- -- Exclude calls rewritten as enumeration literals
+ -- Guard against previous errors
- if Nkind (N) not in N_Subprogram_Call
- and then Nkind (N) /= N_Entry_Call_Statement
- then
+ elsif Error_Posted (N) then
return;
end if;
@@ -3726,175 +3763,115 @@ package body Sem_Warn is
Form1 := First_Formal (Subp);
Act1 := First_Actual (N);
while Present (Form1) and then Present (Act1) loop
- 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 Refer_Same_Object (Act1, Act2) then
- if Is_Generic_Type (Etype (Act2)) then
- return;
- end if;
- -- First case : two writable elementary parameters
- -- that overlap.
+ Form2 := Next_Formal (Form1);
+ Act2 := Next_Actual (Act1);
+ while Present (Form2) and then Present (Act2) 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)
+ -- Ignore formals of generic types; they will be examined when
+ -- instantiated.
- -- Second case : two composite parameters that overlap,
- -- one of which is writable.
+ if Is_Generic_Type (Etype (Form1))
+ or else Is_Generic_Type (Etype (Form2))
+ then
+ null;
- 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 Refer_Same_Object (Act1, Act2) then
- -- Third case : an elementary writable parameter that
- -- overlaps a composite one.
+ -- Case 1: two writable elementary parameters that overlap
- or else (Is_Elementary_Type (Etype (Form1))
- and then Ekind (Form1) /= E_In_Parameter
- and then Is_Composite_Type (Etype (Form2)))
+ 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)
- or else (Is_Elementary_Type (Etype (Form2))
- and then Ekind (Form2) /= E_In_Parameter
- and then Is_Composite_Type (Etype (Form1)))
- then
+ -- Case 2: two composite parameters that overlap, one of
+ -- which is writable.
- -- Guard against previous errors
+ 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))
- if Error_Posted (N)
- or else No (Etype (Act1))
- or else No (Etype (Act2))
- then
- null;
+ -- Case 3: an elementary writable parameter that overlaps
+ -- a composite one.
- -- If the actual is a function call in prefix notation,
- -- there is no real overlap.
+ or else (Is_Elementary_Type (Etype (Form1))
+ and then Ekind (Form1) /= E_In_Parameter
+ and then Is_Composite_Type (Etype (Form2)))
- elsif Nkind (Act2) = N_Function_Call then
- null;
-
- -- 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;
-
- -- Under Ada 2012 we only report warnings on overlapping
- -- arrays and record types if switch is set.
-
- elsif Ada_Version >= Ada_2012
- and then not Is_Elementary_Type (Etype (Form1))
- and then not Warn_On_Overlap
- then
- null;
+ or else (Is_Elementary_Type (Etype (Form2))
+ and then Ekind (Form2) /= E_In_Parameter
+ and then Is_Composite_Type (Etype (Form1)))
+ then
- -- Here we may need to issue overlap message
+ -- Guard against previous errors
- else
- Error_Msg_Warn :=
+ if 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 type is explicitly by-reference, then it is not
+ -- covered by the legality rule, which only applies to
+ -- elementary types. Actually, the aliasing is most
+ -- likely intended, so don't emit a warning either.
- Ada_Version < Ada_2012
+ elsif Explicitly_By_Reference (Form1)
+ or else Explicitly_By_Reference (Form2)
+ 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 versions.
- -- This is clarified by AI12-0216.
+ -- We only report warnings on overlapping arrays and record
+ -- types if switch is set.
- or else not
- (Is_Elementary_Type (Etype (Form1))
- and then Is_Elementary_Type (Etype (Form2)))
+ elsif not Warn_On_Overlap
+ and then not (Is_Elementary_Type (Etype (Form1))
+ and then
+ Is_Elementary_Type (Etype (Form2)))
+ then
+ null;
- -- debug flag -gnatd.E changes the error to a
- -- warning even in Ada 2012 mode.
+ -- Here we may need to issue overlap message
- or else Error_To_Warning;
+ else
+ Error_Msg_Warn :=
- if Is_Elementary_Type (Etype (Act1))
- and then Ekind (Form2) = E_In_Parameter
- then
- null; -- No real aliasing
+ -- Overlap checking is an error only in Ada 2012. For
+ -- earlier versions of Ada, this is a warning.
- elsif Is_Elementary_Type (Etype (Act2))
- and then Ekind (Form2) = E_In_Parameter
- then
- null; -- Ditto
+ Ada_Version < Ada_2012
- -- If the call was written in prefix notation, and
- -- thus its prefix before rewriting was a selected
- -- component, count only visible actuals in call.
+ -- Overlap is only illegal since Ada 2012 and only for
+ -- elementary types (passed by copy). For other types
+ -- we always have a warning in all versions. This is
+ -- clarified by AI12-0216.
- 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
- and then
- Is_Entity_Name (Prefix (Name (Original_Node (N))))
- and then
- Entity (Prefix (Name (Original_Node (N)))) =
- Entity (First_Actual (N))
- then
- if Act1 = First_Actual (N) then
- Error_Msg_FE
- ("<I<`IN OUT` prefix overlaps with "
- & "actual for&", Act1, Form2);
+ or else not
+ (Is_Elementary_Type (Etype (Form1))
+ and then Is_Elementary_Type (Etype (Form2)))
- else
- -- For greater clarity, give name of formal
+ -- debug flag -gnatd.E changes the error to a warning
+ -- even in Ada 2012 mode.
- Error_Msg_Node_2 := Form2;
- Error_Msg_FE
- ("<I<writable actual for & overlaps with "
- & "actual for&", Act1, Form2);
- end if;
+ or else Error_To_Warning;
- else
- -- For greater clarity, give name of formal
+ -- For greater clarity, give name of formal
- Error_Msg_Node_2 := Form2;
+ Error_Msg_Node_2 := Form2;
- -- This is one of the messages
+ -- This is one of the messages
- Error_Msg_FE
- ("<I<writable actual for & overlaps with "
- & "actual for&", Act1, Form1);
- end if;
- end if;
+ Error_Msg_FE
+ ("<I<writable actual for & overlaps with actual for &",
+ Act1, Form1);
end if;
-
- return;
end if;
+ end if;
- Next_Formal (Form2);
- Next_Actual (Act2);
- end loop;
- end if;
+ Next_Formal (Form2);
+ Next_Actual (Act2);
+ end loop;
Next_Formal (Form1);
Next_Actual (Act1);
generated by cgit v1.1 at 2025-05-06 16:06:14 +0000