gcc/ada/sem_warn.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                             S E M _ W A R N                              --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1999-2004 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Alloc;
  28 with Atree;    use Atree;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Fname;    use Fname;
  32 with Lib;      use Lib;
  33 with Nlists;   use Nlists;
  34 with Opt;      use Opt;
  35 with Sem;      use Sem;
  36 with Sem_Ch8;  use Sem_Ch8;
  37 with Sem_Util; use Sem_Util;
  38 with Sinfo;    use Sinfo;
  39 with Sinput;   use Sinput;
  40 with Snames;   use Snames;
  41 with Stand;    use Stand;
  42 with Table;
  43
  44 package body Sem_Warn is
  45
  46    --  The following table collects Id's of entities that are potentially
  47    --  unreferenced. See Check_Unset_Reference for further details.
  48
  49    package Unreferenced_Entities is new Table.Table (
  50      Table_Component_Type => Entity_Id,
  51      Table_Index_Type     => Nat,
  52      Table_Low_Bound      => 1,
  53      Table_Initial        => Alloc.Unreferenced_Entities_Initial,
  54      Table_Increment      => Alloc.Unreferenced_Entities_Increment,
  55      Table_Name           => "Unreferenced_Entities");
  56
  57    ------------------------------
  58    -- Handling of Conditionals --
  59    ------------------------------
  60
  61    --  Note: this is work in progress, the data structures and general
  62    --  approach are defined, but are not in use yet. ???
  63
  64    --  One entry is made in the following table for each branch of
  65    --  a conditional, e.g. an if-then-elsif-else-endif structure
  66    --  creates three entries in this table.
  67
  68    type Branch_Entry is record
  69       Sloc : Source_Ptr;
  70       --  Location for warnings associated with this branch
  71
  72       Defs : Elist_Id;
  73       --  List of entities defined for the first time in this branch. On
  74       --  exit from a conditional structure, any entity that is in the
  75       --  list of all branches is removed (and the entity flagged as
  76       --  defined by the conditional as a whole). Thus after processing
  77       --  a conditional, Defs contains a list of entities defined in this
  78       --  branch for the first time, but not defined at all in some other
  79       --  branch of the same conditional. A value of No_Elist is used to
  80       --  represent the initial empty list.
  81
  82       Next : Nat;
  83       --  Index of next branch for this conditional, zero = last branch
  84    end record;
  85
  86    package Branch_Table is new Table.Table (
  87      Table_Component_Type => Branch_Entry,
  88      Table_Index_Type     => Nat,
  89      Table_Low_Bound      => 1,
  90      Table_Initial        => Alloc.Branches_Initial,
  91      Table_Increment      => Alloc.Branches_Increment,
  92      Table_Name           => "Branches");
  93
  94    --  The following table is used to represent conditionals, there is
  95    --  one entry in this table for each conditional structure.
  96
  97    type Conditional_Entry is record
  98       If_Stmt : Boolean;
  99       --  True for IF statement, False for CASE statement
 100
 101       First_Branch : Nat;
 102       --  Index in Branch table of first branch, zero = none yet
 103
 104       Current_Branch : Nat;
 105       --  Index in Branch table of current branch, zero = none yet
 106    end record;
 107
 108    package Conditional_Table is new Table.Table (
 109      Table_Component_Type => Conditional_Entry,
 110      Table_Index_Type     => Nat,
 111      Table_Low_Bound      => 1,
 112      Table_Initial        => Alloc.Conditionals_Initial,
 113      Table_Increment      => Alloc.Conditionals_Increment,
 114      Table_Name           => "Conditionals");
 115
 116    --  The following table is a stack that keeps track of the current
 117    --  conditional. The Last entry is the top of the stack. An Empty
 118    --  entry represents the start of a compilation unit. Non-zero
 119    --  entries in the stack are indexes into the conditional table.
 120
 121    package Conditional_Stack is new Table.Table (
 122      Table_Component_Type => Nat,
 123      Table_Index_Type     => Nat,
 124      Table_Low_Bound      => 1,
 125      Table_Initial        => Alloc.Conditional_Stack_Initial,
 126      Table_Increment      => Alloc.Conditional_Stack_Increment,
 127      Table_Name           => "Conditional_Stack");
 128
 129    pragma Warnings (Off, Branch_Table);
 130    pragma Warnings (Off, Conditional_Table);
 131    pragma Warnings (Off, Conditional_Stack);
 132    --  Not yet referenced, see note above ???
 133
 134    -----------------------
 135    -- Local Subprograms --
 136    -----------------------
 137
 138    function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean;
 139    --  This returns true if the entity E is declared within a generic package.
 140    --  The point of this is to detect variables which are not assigned within
 141    --  the generic, but might be assigned outside the package for any given
 142    --  instance. These are cases where we leave the warnings to be posted
 143    --  for the instance, when we will know more.
 144
 145    function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean;
 146    --  This function traverses the expression tree represented by the node
 147    --  N and determines if any sub-operand is a reference to an entity for
 148    --  which the Warnings_Off flag is set. True is returned if such an
 149    --  entity is encountered, and False otherwise.
 150
 151    ----------------------
 152    -- Check_References --
 153    ----------------------
 154
 155    procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty) is
 156       E1 : Entity_Id;
 157       UR : Node_Id;
 158
 159       function Missing_Subunits return Boolean;
 160       --  We suppress warnings when there are missing subunits, because this
 161       --  may generate too many false positives: entities in a parent may
 162       --  only be referenced in one of the subunits. We make an exception
 163       --  for subunits that contain no other stubs.
 164
 165       procedure Output_Reference_Error (M : String);
 166       --  Used to output an error message. Deals with posting the error on
 167       --  the body formal in the accept case.
 168
 169       function Publicly_Referenceable (Ent : Entity_Id) return Boolean;
 170       --  This is true if the entity in question is potentially referenceable
 171       --  from another unit. This is true for entities in packages that are
 172       --  at the library level.
 173
 174       ----------------------
 175       -- Missing_Subunits --
 176       ----------------------
 177
 178       function Missing_Subunits return Boolean is
 179          D : Node_Id;
 180
 181       begin
 182          if not Unloaded_Subunits then
 183
 184             --  Normal compilation, all subunits are present
 185
 186             return False;
 187
 188          elsif E /= Main_Unit_Entity then
 189
 190             --  No warnings on a stub that is not the main unit
 191
 192             return True;
 193
 194          elsif Nkind (Unit_Declaration_Node (E)) in N_Proper_Body then
 195             D := First (Declarations (Unit_Declaration_Node (E)));
 196
 197             while Present (D) loop
 198
 199                --  No warnings if the proper body contains nested stubs
 200
 201                if Nkind (D) in N_Body_Stub then
 202                   return True;
 203                end if;
 204
 205                Next (D);
 206             end loop;
 207
 208             return False;
 209
 210          else
 211             --   Missing stubs elsewhere
 212
 213             return True;
 214          end if;
 215       end Missing_Subunits;
 216
 217       ----------------------------
 218       -- Output_Reference_Error --
 219       ----------------------------
 220
 221       procedure Output_Reference_Error (M : String) is
 222       begin
 223          --  Other than accept case, post error on defining identifier
 224
 225          if No (Anod) then
 226             Error_Msg_N (M, E1);
 227
 228          --  Accept case, find body formal to post the message
 229
 230          else
 231             declare
 232                Parm  : Node_Id;
 233                Enod  : Node_Id;
 234                Defid : Entity_Id;
 235
 236             begin
 237                Enod := Anod;
 238
 239                if Present (Parameter_Specifications (Anod)) then
 240                   Parm := First (Parameter_Specifications (Anod));
 241
 242                   while Present (Parm) loop
 243                      Defid := Defining_Identifier (Parm);
 244
 245                      if Chars (E1) = Chars (Defid) then
 246                         Enod := Defid;
 247                         exit;
 248                      end if;
 249
 250                      Next (Parm);
 251                   end loop;
 252                end if;
 253
 254                Error_Msg_NE (M, Enod, E1);
 255             end;
 256          end if;
 257       end Output_Reference_Error;
 258
 259       ----------------------------
 260       -- Publicly_Referenceable --
 261       ----------------------------
 262
 263       function Publicly_Referenceable (Ent : Entity_Id) return Boolean is
 264          P    : Node_Id;
 265          Prev : Node_Id;
 266
 267       begin
 268          --  Examine parents to look for a library level package spec
 269          --  But if we find a body or block or other similar construct
 270          --  along the way, we cannot be referenced.
 271
 272          Prev := Ent;
 273          P    := Parent (Ent);
 274          loop
 275             case Nkind (P) is
 276
 277                --  If we get to top of tree, then publicly referenceable
 278
 279                when N_Empty =>
 280                   return True;
 281
 282                --  If we reach a generic package declaration, then always
 283                --  consider this referenceable, since any instantiation will
 284                --  have access to the entities in the generic package. Note
 285                --  that the package itself may not be instantiated, but then
 286                --  we will get a warning for the package entity
 287                --  Note that generic formal parameters are themselves not
 288                --  publicly referenceable in an instance, and warnings on
 289                --  them are useful.
 290
 291                when N_Generic_Package_Declaration =>
 292                   return
 293                     not Is_List_Member (Prev)
 294                       or else List_Containing (Prev)
 295                         /= Generic_Formal_Declarations (P);
 296
 297                --  if we reach a subprogram body, entity is not referenceable
 298                --  unless it is the defining entity of the body. This will
 299                --  happen, e.g. when a function is an attribute renaming that
 300                --  is rewritten as a body.
 301
 302                when N_Subprogram_Body  =>
 303                   if Ent /= Defining_Entity (P) then
 304                      return False;
 305                   else
 306                      P := Parent (P);
 307                   end if;
 308
 309                --  If we reach any other body, definitely not referenceable
 310
 311                when N_Package_Body    |
 312                     N_Task_Body       |
 313                     N_Entry_Body      |
 314                     N_Protected_Body  |
 315                     N_Block_Statement |
 316                     N_Subunit         =>
 317                   return False;
 318
 319                --  For all other cases, keep looking up tree
 320
 321                when others =>
 322                   Prev := P;
 323                   P    := Parent (P);
 324             end case;
 325          end loop;
 326       end Publicly_Referenceable;
 327
 328    --  Start of processing for Check_References
 329
 330    begin
 331       --  No messages if warnings are suppressed, or if we have detected
 332       --  any real errors so far (this last check avoids junk messages
 333       --  resulting from errors, e.g. a subunit that is not loaded).
 334
 335       if Warning_Mode = Suppress
 336         or else Serious_Errors_Detected /= 0
 337       then
 338          return;
 339       end if;
 340
 341       --  We also skip the messages if any subunits were not loaded (see
 342       --  comment in Sem_Ch10 to understand how this is set, and why it is
 343       --  necessary to suppress the warnings in this case).
 344
 345       if Missing_Subunits then
 346          return;
 347       end if;
 348
 349       --  Otherwise loop through entities, looking for suspicious stuff
 350
 351       E1 := First_Entity (E);
 352       while Present (E1) loop
 353
 354          --  We only look at source entities with warning flag on
 355
 356          if Comes_From_Source (E1) and then not Warnings_Off (E1) then
 357
 358             --  We are interested in variables and out parameters, but we
 359             --  exclude protected types, too complicated to worry about.
 360
 361             if Ekind (E1) = E_Variable
 362                  or else
 363                (Ekind (E1) = E_Out_Parameter
 364                   and then not Is_Protected_Type (Current_Scope))
 365             then
 366                --  Post warning if this object not assigned. Note that we
 367                --  do not consider the implicit initialization of an access
 368                --  type to be the assignment of a value for this purpose.
 369
 370                if Ekind (E1) = E_Out_Parameter
 371                  and then Present (Spec_Entity (E1))
 372                then
 373                   UR := Unset_Reference (Spec_Entity (E1));
 374                else
 375                   UR := Unset_Reference (E1);
 376                end if;
 377
 378                --  If the entity is an out parameter of the current subprogram
 379                --  body, check the warning status of the parameter in the spec.
 380
 381                if Ekind (E1) = E_Out_Parameter
 382                  and then Present (Spec_Entity (E1))
 383                  and then Warnings_Off (Spec_Entity (E1))
 384                then
 385                   null;
 386
 387                elsif Present (UR)
 388                  and then Is_Access_Type (Etype (E1))
 389                then
 390
 391                   --  For access types, the only time we made a UR
 392                   --  entry was for a dereference, and so we post
 393                   --  the appropriate warning here (note that the
 394                   --  dereference may not be explicit in the source,
 395                   --  for example in the case of a dispatching call
 396                   --  with an anonymous access controlling formal, or
 397                   --  of an assignment of a pointer involving a
 398                   --  discriminant check on the designated object).
 399
 400                   Error_Msg_NE ("& may be null?", UR, E1);
 401                   goto Continue;
 402
 403                elsif Never_Set_In_Source (E1)
 404                  and then not Generic_Package_Spec_Entity (E1)
 405                then
 406                   if Warn_On_No_Value_Assigned then
 407
 408                      --  Do not output complaint about never being assigned a
 409                      --  value if a pragma Unreferenced applies to the variable
 410                      --  or if it is a parameter, to the corresponding spec.
 411
 412                      if Has_Pragma_Unreferenced (E1)
 413                        or else (Is_Formal (E1)
 414                                   and then Present (Spec_Entity (E1))
 415                                   and then
 416                                     Has_Pragma_Unreferenced (Spec_Entity (E1)))
 417                      then
 418                         null;
 419
 420                      --  Pragma Unreferenced not set, so output message
 421
 422                      else
 423                         Output_Reference_Error
 424                           ("& is never assigned a value?");
 425
 426                         --  Deal with special case where this variable is
 427                         --  hidden by a loop variable
 428
 429                         if Ekind (E1) = E_Variable
 430                           and then Present (Hiding_Loop_Variable (E1))
 431                         then
 432                            Error_Msg_Sloc := Sloc (E1);
 433                            Error_Msg_N
 434                              ("declaration hides &#?",
 435                               Hiding_Loop_Variable (E1));
 436                            Error_Msg_N
 437                              ("for loop implicitly declares loop variable?",
 438                               Hiding_Loop_Variable (E1));
 439                         end if;
 440                      end if;
 441                   end if;
 442                   goto Continue;
 443
 444                --  Case of variable that could be a constant. Note that we
 445                --  never signal such messages for generic package entities,
 446                --  since a given instance could have modifications outside
 447                --  the package.
 448
 449                elsif Warn_On_Constant
 450                  and then Ekind (E1) = E_Variable
 451                  and then Is_True_Constant (E1)
 452                  and then not Generic_Package_Spec_Entity (E1)
 453                then
 454                   Error_Msg_N
 455                     ("& is not modified, could be declared constant?", E1);
 456                end if;
 457
 458                --  Check for unset reference, note that we exclude access
 459                --  types from this check, since access types do always have
 460                --  a null value, and that seems legitimate in this case.
 461
 462                if Warn_On_No_Value_Assigned and then Present (UR) then
 463
 464                   --  For other than access type, go back to original node
 465                   --  to deal with case where original unset reference
 466                   --  has been rewritten during expansion.
 467
 468                   UR := Original_Node (UR);
 469
 470                   --  In some cases, the original node may be a type
 471                   --  conversion or qualification, and in this case
 472                   --  we want the object entity inside.
 473
 474                   while Nkind (UR) = N_Type_Conversion
 475                     or else Nkind (UR) = N_Qualified_Expression
 476                   loop
 477                      UR := Expression (UR);
 478                   end loop;
 479
 480                   --  Here we issue the warning, all checks completed
 481                   --  If the unset reference is prefix of a selected
 482                   --  component that comes from source, mention the
 483                   --  component as well. If the selected component comes
 484                   --  from expansion, all we know is that the entity is
 485                   --  not fully initialized at the point of the reference.
 486                   --  Locate an unintialized component to get a better
 487                   --  error message.
 488
 489                   if Nkind (Parent (UR)) = N_Selected_Component then
 490                      Error_Msg_Node_2 := Selector_Name (Parent (UR));
 491
 492                      if not Comes_From_Source (Parent (UR)) then
 493                         declare
 494                            Comp : Entity_Id;
 495
 496                         begin
 497                            Comp := First_Entity (Etype (E1));
 498                            while Present (Comp) loop
 499                               if Ekind (Comp) = E_Component
 500                                 and then Nkind (Parent (Comp)) =
 501                                   N_Component_Declaration
 502                                 and then No (Expression (Parent (Comp)))
 503                               then
 504                                  Error_Msg_Node_2 := Comp;
 505                                  exit;
 506                               end if;
 507
 508                               Next_Entity (Comp);
 509                            end loop;
 510                         end;
 511                      end if;
 512
 513                      Error_Msg_N
 514                        ("`&.&` may be referenced before it has a value?",
 515                         UR);
 516                   else
 517                      Error_Msg_N
 518                        ("& may be referenced before it has a value?",
 519                         UR);
 520                   end if;
 521
 522                   goto Continue;
 523                end if;
 524             end if;
 525
 526             --  Then check for unreferenced entities. Note that we are only
 527             --  interested in entities which do not have the Referenced flag
 528             --  set. The Referenced_As_LHS flag is interesting only if the
 529             --  Referenced flag is not set.
 530
 531             if not Referenced (E1)
 532
 533                --  Check that warnings on unreferenced entities are enabled
 534
 535               and then ((Check_Unreferenced and then not Is_Formal (E1))
 536                            or else
 537                         (Check_Unreferenced_Formals and then Is_Formal (E1))
 538                            or else
 539                         (Warn_On_Modified_Unread
 540                           and then Referenced_As_LHS (E1)))
 541
 542                --  Labels, and enumeration literals, and exceptions. The
 543                --  warnings are also placed on local packages that cannot
 544                --  be referenced from elsewhere, including those declared
 545                --  within a package body.
 546
 547                and then (Is_Object (E1)
 548                            or else
 549                          Is_Type (E1)
 550                            or else
 551                          Ekind (E1) = E_Label
 552                            or else
 553                          Ekind (E1) = E_Exception
 554                            or else
 555                          Ekind (E1) = E_Named_Integer
 556                            or else
 557                          Ekind (E1) = E_Named_Real
 558                            or else
 559                          Is_Overloadable (E1)
 560                            or else
 561                              (Ekind (E1) = E_Package
 562                                and then
 563                                 (Ekind (E) = E_Function
 564                                   or else Ekind (E) = E_Package_Body
 565                                   or else Ekind (E) = E_Procedure
 566                                   or else Ekind (E) = E_Block)))
 567
 568                --  Exclude instantiations, since there is no reason why
 569                --  every entity in an instantiation should be referenced.
 570
 571                and then Instantiation_Location (Sloc (E1)) = No_Location
 572
 573                --  Exclude formal parameters from bodies if the corresponding
 574                --  spec entity has been referenced in the case where there is
 575                --  a separate spec.
 576
 577                and then not (Is_Formal (E1)
 578                                and then
 579                              Ekind (Scope (E1)) = E_Subprogram_Body
 580                                and then
 581                              Present (Spec_Entity (E1))
 582                                and then
 583                              Referenced (Spec_Entity (E1)))
 584
 585                --  Consider private type referenced if full view is referenced
 586                --  If there is not full view, this is a generic type on which
 587                --  warnings are also useful.
 588
 589                and then
 590                  not (Is_Private_Type (E1)
 591                    and then
 592                      Present (Full_View (E1))
 593                        and then Referenced (Full_View (E1)))
 594
 595                --  Don't worry about full view, only about private type
 596
 597                and then not Has_Private_Declaration (E1)
 598
 599                --  Eliminate dispatching operations from consideration, we
 600                --  cannot tell if these are referenced or not in any easy
 601                --  manner (note this also catches Adjust/Finalize/Initialize)
 602
 603                and then not Is_Dispatching_Operation (E1)
 604
 605                --  Check entity that can be publicly referenced (we do not
 606                --  give messages for such entities, since there could be
 607                --  other units, not involved in this compilation, that
 608                --  contain relevant references.
 609
 610                and then not Publicly_Referenceable (E1)
 611
 612                --  Class wide types are marked as source entities, but
 613                --  they are not really source entities, and are always
 614                --  created, so we do not care if they are not referenced.
 615
 616                and then Ekind (E1) /= E_Class_Wide_Type
 617
 618                --  Objects other than parameters of task types are allowed
 619                --  to be non-referenced, since they start up tasks!
 620
 621                and then ((Ekind (E1) /= E_Variable
 622                              and then Ekind (E1) /= E_Constant
 623                              and then Ekind (E1) /= E_Component)
 624                            or else not Is_Task_Type (Etype (E1)))
 625
 626                --  For subunits, only place warnings on the main unit
 627                --  itself, since parent units are not completely compiled
 628
 629                and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit
 630                            or else
 631                          Get_Source_Unit (E1) = Main_Unit)
 632             then
 633                --  Suppress warnings in internal units if not in -gnatg
 634                --  mode (these would be junk warnings for an applications
 635                --  program, since they refer to problems in internal units)
 636
 637                if GNAT_Mode
 638                  or else not
 639                    Is_Internal_File_Name
 640                      (Unit_File_Name (Get_Source_Unit (E1)))
 641                then
 642                   --  We do not immediately flag the error. This is because
 643                   --  we have not expanded generic bodies yet, and they may
 644                   --  have the missing reference. So instead we park the
 645                   --  entity on a list, for later processing. However, for
 646                   --  the accept case, post the error right here, since we
 647                   --  have the information now in this case.
 648
 649                   if Present (Anod) then
 650                      Output_Reference_Error ("& is not referenced?");
 651
 652                   else
 653                      Unreferenced_Entities.Increment_Last;
 654                      Unreferenced_Entities.Table
 655                        (Unreferenced_Entities.Last) := E1;
 656                   end if;
 657                end if;
 658
 659             --  Generic units are referenced in the generic body,
 660             --  but if they are not public and never instantiated
 661             --  we want to force a warning on them. We treat them
 662             --  as redundant constructs to minimize noise.
 663
 664             elsif Is_Generic_Subprogram (E1)
 665               and then not Is_Instantiated (E1)
 666               and then not Publicly_Referenceable (E1)
 667               and then Instantiation_Depth (Sloc (E1)) = 0
 668               and then Warn_On_Redundant_Constructs
 669             then
 670                Unreferenced_Entities.Increment_Last;
 671                Unreferenced_Entities.Table (Unreferenced_Entities.Last) := E1;
 672
 673                --  Force warning on entity.
 674
 675                Set_Referenced (E1, False);
 676             end if;
 677          end if;
 678
 679          --  Recurse into nested package or block. Do not recurse into a
 680          --  formal package, because the correponding body is not analyzed.
 681
 682          <<Continue>>
 683             if ((Ekind (E1) = E_Package or else Ekind (E1) = E_Generic_Package)
 684                   and then Nkind (Parent (E1)) = N_Package_Specification
 685                   and then
 686                     Nkind (Original_Node (Unit_Declaration_Node (E1)))
 687                       /= N_Formal_Package_Declaration)
 688
 689               or else Ekind (E1) = E_Block
 690             then
 691                Check_References (E1);
 692             end if;
 693
 694             Next_Entity (E1);
 695       end loop;
 696    end Check_References;
 697
 698    ---------------------------
 699    -- Check_Unset_Reference --
 700    ---------------------------
 701
 702    procedure Check_Unset_Reference (N : Node_Id) is
 703    begin
 704       --  Nothing to do if warnings suppressed
 705
 706       if Warning_Mode = Suppress then
 707          return;
 708       end if;
 709
 710       --  Ignore reference to non-scalar if not from source. Almost always
 711       --  such references are bogus (e.g. calls to init procs to set
 712       --  default discriminant values).
 713
 714       if not Comes_From_Source (N)
 715         and then not Is_Scalar_Type (Etype (N))
 716       then
 717          return;
 718       end if;
 719
 720       --  Otherwise see what kind of node we have. If the entity already
 721       --  has an unset reference, it is not necessarily the earliest in
 722       --  the text, because resolution of the prefix of selected components
 723       --  is completed before the resolution of the selected component itself.
 724       --  as a result, given  (R /= null and then R.X > 0), the occurrences
 725       --  of R are examined in right-to-left order. If there is already an
 726       --  unset reference, we check whether N is earlier before proceeding.
 727
 728       case Nkind (N) is
 729          when N_Identifier | N_Expanded_Name =>
 730             declare
 731                E : constant Entity_Id := Entity (N);
 732
 733             begin
 734                if (Ekind (E) = E_Variable
 735                     or else Ekind (E) = E_Out_Parameter)
 736                  and then Never_Set_In_Source (E)
 737                  and then (No (Unset_Reference (E))
 738                              or else Earlier_In_Extended_Unit
 739                                (Sloc (N),  Sloc (Unset_Reference (E))))
 740                  and then not Warnings_Off (E)
 741                then
 742                   --  We may have an unset reference. The first test is
 743                   --  whether we are accessing a discriminant of a record
 744                   --  or a component with default initialization. Both of
 745                   --  these cases can be ignored, since the actual object
 746                   --  that is referenced is definitely initialized. Note
 747                   --  that this covers the case of reading discriminants
 748                   --  of an out parameter, which is OK even in Ada 83.
 749
 750                   --  Note that we are only interested in a direct reference
 751                   --  to a record component here. If the reference is via an
 752                   --  access type, then the access object is being referenced,
 753                   --  not the record, and still deserves an unset reference.
 754
 755                   if Nkind (Parent (N)) = N_Selected_Component
 756                     and not Is_Access_Type (Etype (N))
 757                   then
 758                      declare
 759                         ES : constant Entity_Id :=
 760                                Entity (Selector_Name (Parent (N)));
 761
 762                      begin
 763                         if Ekind (ES) = E_Discriminant
 764                           or else Present (Expression (Declaration_Node (ES)))
 765                         then
 766                            return;
 767                         end if;
 768                      end;
 769                   end if;
 770
 771                   --  Here we have a potential unset reference. But before we
 772                   --  get worried about it, we have to make sure that the
 773                   --  entity declaration is in the same procedure as the
 774                   --  reference, since if they are in separate procedures,
 775                   --  then we have no idea about sequential execution.
 776
 777                   --  The tests in the loop below catch all such cases, but
 778                   --  do allow the reference to appear in a loop, block, or
 779                   --  package spec that is nested within the declaring scope.
 780                   --  As always, it is possible to construct cases where the
 781                   --  warning is wrong, that is why it is a warning!
 782
 783                   declare
 784                      SR : Entity_Id;
 785                      SE : constant Entity_Id := Scope (E);
 786
 787                   begin
 788                      SR := Current_Scope;
 789                      while SR /= SE loop
 790                         if SR = Standard_Standard
 791                           or else Is_Subprogram (SR)
 792                           or else Is_Concurrent_Body (SR)
 793                           or else Is_Concurrent_Type (SR)
 794                         then
 795                            return;
 796                         end if;
 797
 798                         SR := Scope (SR);
 799                      end loop;
 800
 801                      --  Case of reference has an access type. This is a
 802                      --  special case since access types are always set to
 803                      --  null so cannot be truly uninitialized, but we still
 804                      --  want to warn about cases of obvious null dereference.
 805
 806                      if Is_Access_Type (Etype (N)) then
 807                         declare
 808                            P : Node_Id;
 809
 810                            function Process
 811                              (N    : Node_Id)
 812                               return Traverse_Result;
 813                            --  Process function for instantation of Traverse
 814                            --  below. Checks if N contains reference to E
 815                            --  other than a dereference.
 816
 817                            function Ref_In (Nod : Node_Id) return Boolean;
 818                            --  Determines whether Nod contains a reference
 819                            --  to the entity E that is not a dereference.
 820
 821                            function Process
 822                              (N    : Node_Id)
 823                               return Traverse_Result
 824                            is
 825                            begin
 826                               if Is_Entity_Name (N)
 827                                 and then Entity (N) = E
 828                                 and then not Is_Dereferenced (N)
 829                               then
 830                                  return Abandon;
 831                               else
 832                                  return OK;
 833                               end if;
 834                            end Process;
 835
 836                            function Ref_In (Nod : Node_Id) return Boolean is
 837                               function Traverse is new Traverse_Func (Process);
 838
 839                            begin
 840                               return Traverse (Nod) = Abandon;
 841                            end Ref_In;
 842
 843                         begin
 844                            --  Don't bother if we are inside an instance,
 845                            --  since the compilation of the generic template
 846                            --  is where the warning should be issued.
 847
 848                            if In_Instance then
 849                               return;
 850                            end if;
 851
 852                            --  Don't bother if this is not the main unit.
 853                            --  If we try to give this warning for with'ed
 854                            --  units, we get some false positives, since
 855                            --  we do not record references in other units.
 856
 857                            if not In_Extended_Main_Source_Unit (E)
 858                                 or else
 859                               not In_Extended_Main_Source_Unit (N)
 860                            then
 861                               return;
 862                            end if;
 863
 864                            --  We are only interested in deferences
 865
 866                            if not Is_Dereferenced (N) then
 867                               return;
 868                            end if;
 869
 870                            --  One more check, don't bother with references
 871                            --  that are inside conditional statements or while
 872                            --  loops if the condition references the entity in
 873                            --  question. This avoids most false positives.
 874
 875                            P := Parent (N);
 876                            loop
 877                               P := Parent (P);
 878                               exit when No (P);
 879
 880                               if (Nkind (P) = N_If_Statement
 881                                      or else
 882                                    Nkind (P) = N_Elsif_Part)
 883                                  and then Ref_In (Condition (P))
 884                               then
 885                                  return;
 886
 887                               elsif Nkind (P) = N_Loop_Statement
 888                                 and then Present (Iteration_Scheme (P))
 889                                 and then
 890                                   Ref_In (Condition (Iteration_Scheme (P)))
 891                               then
 892                                  return;
 893                               end if;
 894                            end loop;
 895                         end;
 896                      end if;
 897
 898                      --  Here we definitely have a case for giving a warning
 899                      --  for a reference to an unset value. But we don't give
 900                      --  the warning now. Instead we set the Unset_Reference
 901                      --  field of the identifier involved. The reason for this
 902                      --  is that if we find the variable is never ever assigned
 903                      --  a value then that warning is more important and there
 904                      --  is no point in giving the reference warning.
 905
 906                      --  If this is an identifier, set the field directly
 907
 908                      if Nkind (N) = N_Identifier then
 909                         Set_Unset_Reference (E, N);
 910
 911                      --  Otherwise it is an expanded name, so set the field
 912                      --  of the actual identifier for the reference.
 913
 914                      else
 915                         Set_Unset_Reference (E, Selector_Name (N));
 916                      end if;
 917                   end;
 918                end if;
 919             end;
 920
 921          when N_Indexed_Component | N_Slice =>
 922             Check_Unset_Reference (Prefix (N));
 923
 924          when N_Selected_Component =>
 925
 926             if Present (Entity (Selector_Name (N)))
 927               and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
 928             then
 929                --   A discriminant is always initialized
 930
 931                null;
 932
 933             else
 934                Check_Unset_Reference (Prefix (N));
 935             end if;
 936
 937          when N_Type_Conversion | N_Qualified_Expression =>
 938             Check_Unset_Reference (Expression (N));
 939
 940          when others =>
 941             null;
 942
 943       end case;
 944    end Check_Unset_Reference;
 945
 946    ------------------------
 947    -- Check_Unused_Withs --
 948    ------------------------
 949
 950    procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit) is
 951       Cnode : Node_Id;
 952       Item  : Node_Id;
 953       Lunit : Node_Id;
 954       Ent   : Entity_Id;
 955
 956       Munite : constant Entity_Id := Cunit_Entity (Main_Unit);
 957       --  This is needed for checking the special renaming case
 958
 959       procedure Check_One_Unit (Unit : Unit_Number_Type);
 960       --  Subsidiary procedure, performs checks for specified unit
 961
 962       --------------------
 963       -- Check_One_Unit --
 964       --------------------
 965
 966       procedure Check_One_Unit (Unit : Unit_Number_Type) is
 967          Is_Visible_Renaming : Boolean := False;
 968          Pack                : Entity_Id;
 969
 970          procedure Check_Inner_Package (Pack : Entity_Id);
 971          --  Pack is a package local to a unit in a with_clause. Both the
 972          --  unit and Pack are referenced. If none of the entities in Pack
 973          --  are referenced, then the only occurrence of Pack is in a use
 974          --  clause or a pragma, and a warning is worthwhile as well.
 975
 976          function Check_System_Aux return Boolean;
 977          --  Before giving a warning on a with_clause for System, check
 978          --  whether a system extension is present.
 979
 980          function Find_Package_Renaming
 981            (P : Entity_Id;
 982             L : Entity_Id) return Entity_Id;
 983          --  The only reference to a context unit may be in a renaming
 984          --  declaration. If this renaming declares a visible entity, do
 985          --  not warn that the context clause could be moved to the body,
 986          --  because the renaming may be intented to re-export the unit.
 987
 988          -------------------------
 989          -- Check_Inner_Package --
 990          -------------------------
 991
 992          procedure Check_Inner_Package (Pack : Entity_Id) is
 993             E  : Entity_Id;
 994             Un : constant Node_Id := Sinfo.Unit (Cnode);
 995
 996             function Check_Use_Clause (N : Node_Id) return Traverse_Result;
 997             --  If N is a use_clause for Pack, emit warning.
 998
 999             procedure Check_Use_Clauses is new
1000               Traverse_Proc (Check_Use_Clause);
1001
1002             ----------------------
1003             -- Check_Use_Clause --
1004             ----------------------
1005
1006             function Check_Use_Clause (N : Node_Id) return Traverse_Result is
1007                Nam  : Node_Id;
1008
1009             begin
1010                if Nkind (N) = N_Use_Package_Clause then
1011                   Nam := First (Names (N));
1012
1013                   while Present (Nam) loop
1014                      if Entity (Nam) = Pack then
1015                         Error_Msg_Qual_Level := 1;
1016                         Error_Msg_NE
1017                           ("no entities of package& are referenced?",
1018                              Nam, Pack);
1019                         Error_Msg_Qual_Level := 0;
1020                      end if;
1021
1022                      Next (Nam);
1023                   end loop;
1024                end if;
1025
1026                return OK;
1027             end Check_Use_Clause;
1028
1029          --  Start of processing for Check_Inner_Package
1030
1031          begin
1032             E := First_Entity (Pack);
1033
1034             while Present (E) loop
1035                if Referenced (E) then
1036                   return;
1037                end if;
1038
1039                Next_Entity (E);
1040             end loop;
1041
1042             --  No entities of the package are referenced. Check whether
1043             --  the reference to the package itself is a use clause, and
1044             --  if so place a warning on it.
1045
1046             Check_Use_Clauses (Un);
1047          end Check_Inner_Package;
1048
1049          ----------------------
1050          -- Check_System_Aux --
1051          ----------------------
1052
1053          function Check_System_Aux return Boolean is
1054             Ent : Entity_Id;
1055
1056          begin
1057             if Chars (Lunit) = Name_System
1058                and then Scope (Lunit) = Standard_Standard
1059                and then Present_System_Aux
1060             then
1061                Ent := First_Entity (System_Aux_Id);
1062
1063                while Present (Ent) loop
1064                   if Referenced (Ent) then
1065                      return True;
1066                   end if;
1067
1068                   Next_Entity (Ent);
1069                end loop;
1070             end if;
1071
1072             return False;
1073          end Check_System_Aux;
1074
1075          ---------------------------
1076          -- Find_Package_Renaming --
1077          ---------------------------
1078
1079          function Find_Package_Renaming
1080            (P : Entity_Id;
1081             L : Entity_Id) return Entity_Id
1082          is
1083             E1 : Entity_Id;
1084             R  : Entity_Id;
1085
1086          begin
1087             Is_Visible_Renaming := False;
1088             E1 := First_Entity (P);
1089
1090             while Present (E1) loop
1091                if Ekind (E1) = E_Package
1092                   and then Renamed_Object (E1) = L
1093                then
1094                   Is_Visible_Renaming := not Is_Hidden (E1);
1095                   return E1;
1096
1097                elsif Ekind (E1) = E_Package
1098                  and then No (Renamed_Object (E1))
1099                  and then not Is_Generic_Instance (E1)
1100                then
1101                   R := Find_Package_Renaming (E1, L);
1102
1103                   if Present (R) then
1104                      Is_Visible_Renaming := not Is_Hidden (R);
1105                      return R;
1106                   end if;
1107                end if;
1108
1109                Next_Entity (E1);
1110             end loop;
1111
1112             return Empty;
1113          end Find_Package_Renaming;
1114
1115       --  Start of processing for Check_One_Unit
1116
1117       begin
1118          Cnode := Cunit (Unit);
1119
1120          --  Only do check in units that are part of the extended main
1121          --  unit. This is actually a necessary restriction, because in
1122          --  the case of subprogram acting as its own specification,
1123          --  there can be with's in subunits that we will not see.
1124
1125          if not In_Extended_Main_Source_Unit (Cnode) then
1126             return;
1127
1128          --  In configurable run time mode, we remove the bodies of
1129          --  non-inlined subprograms, which may lead to spurious warnings,
1130          --  which are clearly undesirable.
1131
1132          elsif Configurable_Run_Time_Mode
1133            and then Is_Predefined_File_Name (Unit_File_Name (Unit))
1134          then
1135             return;
1136          end if;
1137
1138          --  Loop through context items in this unit
1139
1140          Item := First (Context_Items (Cnode));
1141          while Present (Item) loop
1142             if Nkind (Item) = N_With_Clause
1143                and then not Implicit_With (Item)
1144                and then In_Extended_Main_Source_Unit (Item)
1145             then
1146                Lunit := Entity (Name (Item));
1147
1148                --  Check if this unit is referenced
1149
1150                if not Referenced (Lunit) then
1151
1152                   --  Suppress warnings in internal units if not in -gnatg
1153                   --  mode (these would be junk warnings for an applications
1154                   --  program, since they refer to problems in internal units)
1155
1156                   if GNAT_Mode
1157                     or else not Is_Internal_File_Name (Unit_File_Name (Unit))
1158                   then
1159                      --  Here we definitely have a non-referenced unit. If
1160                      --  it is the special call for a spec unit, then just
1161                      --  set the flag to be read later.
1162
1163                      if Unit = Spec_Unit then
1164                         Set_Unreferenced_In_Spec (Item);
1165
1166                      --  Otherwise simple unreferenced message
1167
1168                      else
1169                         Error_Msg_N
1170                           ("unit& is not referenced?", Name (Item));
1171                      end if;
1172                   end if;
1173
1174                --  If main unit is a renaming of this unit, then we consider
1175                --  the with to be OK (obviously it is needed in this case!)
1176
1177                elsif Present (Renamed_Entity (Munite))
1178                   and then Renamed_Entity (Munite) = Lunit
1179                then
1180                   null;
1181
1182                --  If this unit is referenced, and it is a package, we
1183                --  do another test, to see if any of the entities in the
1184                --  package are referenced. If none of the entities are
1185                --  referenced, we still post a warning. This occurs if
1186                --  the only use of the package is in a use clause, or
1187                --  in a package renaming declaration.
1188
1189                elsif Ekind (Lunit) = E_Package then
1190
1191                   --  If Is_Instantiated is set, it means that the package
1192                   --  is implicitly instantiated (this is the case of a
1193                   --  parent instance or an actual for a generic package
1194                   --  formal), and this counts as a reference.
1195
1196                   if Is_Instantiated (Lunit) then
1197                      null;
1198
1199                   --  If no entities in package, and there is a pragma
1200                   --  Elaborate_Body present, then assume that this with
1201                   --  is done for purposes of this elaboration.
1202
1203                   elsif No (First_Entity (Lunit))
1204                     and then Has_Pragma_Elaborate_Body (Lunit)
1205                   then
1206                      null;
1207
1208                   --  Otherwise see if any entities have been referenced
1209
1210                   else
1211                      Ent := First_Entity (Lunit);
1212                      loop
1213                         --  No more entities, and we did not find one
1214                         --  that was referenced. Means we have a definite
1215                         --  case of a with none of whose entities was
1216                         --  referenced.
1217
1218                         if No (Ent) then
1219
1220                            --  If in spec, just set the flag
1221
1222                            if Unit = Spec_Unit then
1223                               Set_No_Entities_Ref_In_Spec (Item);
1224
1225                            elsif Check_System_Aux then
1226                               null;
1227
1228                            --  Else give the warning
1229
1230                            else
1231                               Error_Msg_N
1232                                 ("no entities of & are referenced?",
1233                                  Name (Item));
1234
1235                               --  Look for renamings of this package, and
1236                               --  flag them as well. If the original package
1237                               --  has warnings off, we suppress the warning
1238                               --  on the renaming as well.
1239
1240                               Pack := Find_Package_Renaming (Munite, Lunit);
1241
1242                               if Present (Pack)
1243                                 and then not Warnings_Off (Lunit)
1244                               then
1245                                  Error_Msg_NE
1246                                    ("no entities of & are referenced?",
1247                                      Unit_Declaration_Node (Pack),
1248                                        Pack);
1249                               end if;
1250                            end if;
1251
1252                            exit;
1253
1254                         --  Case of next entity is referenced
1255
1256                         elsif Referenced (Ent)
1257                           or else Referenced_As_LHS (Ent)
1258                         then
1259                            --  This means that the with is indeed fine, in
1260                            --  that it is definitely needed somewhere, and
1261                            --  we can quite worrying about this one.
1262
1263                            --  Except for one little detail, if either of
1264                            --  the flags was set during spec processing,
1265                            --  this is where we complain that the with
1266                            --  could be moved from the spec. If the spec
1267                            --  contains a visible renaming of the package,
1268                            --  inhibit warning to move with_clause to body.
1269
1270                            if Ekind (Munite) = E_Package_Body then
1271                               Pack :=
1272                                 Find_Package_Renaming
1273                                   (Spec_Entity (Munite), Lunit);
1274                            end if;
1275
1276                            if Unreferenced_In_Spec (Item) then
1277                               Error_Msg_N
1278                                 ("unit& is not referenced in spec?",
1279                                  Name (Item));
1280
1281                            elsif No_Entities_Ref_In_Spec (Item) then
1282                               Error_Msg_N
1283                                 ("no entities of & are referenced in spec?",
1284                                  Name (Item));
1285
1286                            else
1287                               if Ekind (Ent) = E_Package then
1288                                  Check_Inner_Package (Ent);
1289                               end if;
1290
1291                               exit;
1292                            end if;
1293
1294                            if not Is_Visible_Renaming then
1295                               Error_Msg_N
1296                                 ("\with clause might be moved to body?",
1297                                  Name (Item));
1298                            end if;
1299
1300                            exit;
1301
1302                         --  Move to next entity to continue search
1303
1304                         else
1305                            Next_Entity (Ent);
1306                         end if;
1307                      end loop;
1308                   end if;
1309
1310                --  For a generic package, the only interesting kind of
1311                --  reference is an instantiation, since entities cannot
1312                --  be referenced directly.
1313
1314                elsif Is_Generic_Unit (Lunit) then
1315
1316                   --  Unit was never instantiated, set flag for case of spec
1317                   --  call, or give warning for normal call.
1318
1319                   if not Is_Instantiated (Lunit) then
1320                      if Unit = Spec_Unit then
1321                         Set_Unreferenced_In_Spec (Item);
1322                      else
1323                         Error_Msg_N
1324                           ("unit& is never instantiated?", Name (Item));
1325                      end if;
1326
1327                   --  If unit was indeed instantiated, make sure that
1328                   --  flag is not set showing it was uninstantiated in
1329                   --  the spec, and if so, give warning.
1330
1331                   elsif Unreferenced_In_Spec (Item) then
1332                      Error_Msg_N
1333                        ("unit& is not instantiated in spec?", Name (Item));
1334                      Error_Msg_N
1335                        ("\with clause can be moved to body?", Name (Item));
1336                   end if;
1337                end if;
1338             end if;
1339
1340             Next (Item);
1341          end loop;
1342
1343       end Check_One_Unit;
1344
1345    --  Start of processing for Check_Unused_Withs
1346
1347    begin
1348       if not Opt.Check_Withs
1349         or else Operating_Mode = Check_Syntax
1350       then
1351          return;
1352       end if;
1353
1354       --  Flag any unused with clauses, but skip this step if we are
1355       --  compiling a subunit on its own, since we do not have enough
1356       --  information to determine whether with's are used. We will get
1357       --  the relevant warnings when we compile the parent. This is the
1358       --  normal style of GNAT compilation in any case.
1359
1360       if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit then
1361          return;
1362       end if;
1363
1364       --  Process specified units
1365
1366       if Spec_Unit = No_Unit then
1367
1368          --  For main call, check all units
1369
1370          for Unit in Main_Unit .. Last_Unit loop
1371             Check_One_Unit (Unit);
1372          end loop;
1373
1374       else
1375          --  For call for spec, check only the spec
1376
1377          Check_One_Unit (Spec_Unit);
1378       end if;
1379    end Check_Unused_Withs;
1380
1381    ---------------------------------
1382    -- Generic_Package_Spec_Entity --
1383    ---------------------------------
1384
1385    function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean is
1386       S : Entity_Id;
1387
1388    begin
1389       if Is_Package_Body_Entity (E) then
1390          return False;
1391
1392       else
1393          S := Scope (E);
1394
1395          loop
1396             if S = Standard_Standard then
1397                return False;
1398
1399             elsif Ekind (S) = E_Generic_Package then
1400                return True;
1401
1402             elsif Ekind (S) = E_Package then
1403                S := Scope (S);
1404
1405             else
1406                return False;
1407             end if;
1408          end loop;
1409       end if;
1410    end Generic_Package_Spec_Entity;
1411
1412    -------------------------------------
1413    -- Operand_Has_Warnings_Suppressed --
1414    -------------------------------------
1415
1416    function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean is
1417
1418       function Check_For_Warnings (N : Node_Id) return Traverse_Result;
1419       --  Function used to check one node to see if it is or was originally
1420       --  a reference to an entity for which Warnings are off. If so, Abandon
1421       --  is returned, otherwise OK_Orig is returned to continue the traversal
1422       --  of the original expression.
1423
1424       function Traverse is new Traverse_Func (Check_For_Warnings);
1425       --  Function used to traverse tree looking for warnings
1426
1427       ------------------------
1428       -- Check_For_Warnings --
1429       ------------------------
1430
1431       function Check_For_Warnings (N : Node_Id) return Traverse_Result is
1432          R : constant Node_Id := Original_Node (N);
1433
1434       begin
1435          if Nkind (R) in N_Has_Entity
1436            and then Present (Entity (R))
1437            and then Warnings_Off (Entity (R))
1438          then
1439             return Abandon;
1440          else
1441             return OK_Orig;
1442          end if;
1443       end Check_For_Warnings;
1444
1445    --  Start of processing for Operand_Has_Warnings_Suppressed
1446
1447    begin
1448       return Traverse (N) = Abandon;
1449
1450    --  If any exception occurs, then something has gone wrong, and this is
1451    --  only a minor aesthetic issue anyway, so just say we did not find what
1452    --  we are looking for, rather than blow up.
1453
1454    exception
1455       when others =>
1456          return False;
1457    end Operand_Has_Warnings_Suppressed;
1458
1459    ----------------------------------
1460    -- Output_Unreferenced_Messages --
1461    ----------------------------------
1462
1463    procedure Output_Unreferenced_Messages is
1464       E : Entity_Id;
1465
1466    begin
1467       for J in Unreferenced_Entities.First ..
1468                Unreferenced_Entities.Last
1469       loop
1470          E := Unreferenced_Entities.Table (J);
1471
1472          if not Referenced (E) and then not Warnings_Off (E) then
1473             case Ekind (E) is
1474                when E_Variable =>
1475
1476                   --  Case of variable that is assigned but not read. We
1477                   --  suppress the message if the variable is volatile,
1478                   --  has an address clause, or is imported.
1479
1480                   if Referenced_As_LHS (E)
1481                     and then No (Address_Clause (E))
1482                     and then not Is_Volatile (E)
1483                   then
1484                      if Warn_On_Modified_Unread
1485                        and then not Is_Imported (E)
1486
1487                         --  Suppress the message for aliased, renamed
1488                         --  and access variables since there may be
1489                         --  other entities that read the memory location.
1490
1491                        and then not Is_Aliased (E)
1492                        and then No (Renamed_Object (E))
1493                        and then not (Is_Access_Type (Etype (E))
1494                                        or else
1495
1496                         --  Case of private access type, must examine the
1497                         --  full view due to visibility issues.
1498
1499                                        (Is_Private_Type (Etype (E))
1500                                           and then
1501                                           Is_Access_Type
1502                                             (Full_View (Etype (E)))))
1503                      then
1504                         Error_Msg_N
1505                           ("variable & is assigned but never read?", E);
1506                      end if;
1507
1508                   --  Normal case of neither assigned nor read
1509
1510                   else
1511                      if Present (Renamed_Object (E))
1512                        and then Comes_From_Source (Renamed_Object (E))
1513                      then
1514                         Error_Msg_N
1515                           ("renamed variable & is not referenced?", E);
1516                      else
1517                         Error_Msg_N
1518                           ("variable & is not referenced?", E);
1519                      end if;
1520                   end if;
1521
1522                when E_Constant =>
1523                   if Present (Renamed_Object (E))
1524                     and then Comes_From_Source (Renamed_Object (E))
1525                   then
1526                      Error_Msg_N ("renamed constant & is not referenced?", E);
1527                   else
1528                      Error_Msg_N ("constant & is not referenced?", E);
1529                   end if;
1530
1531                when E_In_Parameter     |
1532                     E_Out_Parameter    |
1533                     E_In_Out_Parameter =>
1534
1535                   --  Do not emit message for formals of a renaming, because
1536                   --  they are never referenced explicitly.
1537
1538                   if Nkind (Original_Node (Unit_Declaration_Node (Scope (E))))
1539                     /= N_Subprogram_Renaming_Declaration
1540                   then
1541                      Error_Msg_N ("formal parameter & is not referenced?", E);
1542                   end if;
1543
1544                when E_Named_Integer    |
1545                     E_Named_Real       =>
1546                   Error_Msg_N ("named number & is not referenced?", E);
1547
1548                when E_Enumeration_Literal =>
1549                   Error_Msg_N ("literal & is not referenced?", E);
1550
1551                when E_Function         =>
1552                   Error_Msg_N ("function & is not referenced?", E);
1553
1554                when E_Procedure         =>
1555                   Error_Msg_N ("procedure & is not referenced?", E);
1556
1557                when E_Generic_Procedure =>
1558                   Error_Msg_N
1559                     ("generic procedure & is never instantiated?", E);
1560
1561                when E_Generic_Function  =>
1562                   Error_Msg_N ("generic function & is never instantiated?", E);
1563
1564                when Type_Kind          =>
1565                   Error_Msg_N ("type & is not referenced?", E);
1566
1567                when others =>
1568                   Error_Msg_N ("& is not referenced?", E);
1569             end case;
1570
1571             Set_Warnings_Off (E);
1572          end if;
1573       end loop;
1574    end Output_Unreferenced_Messages;
1575
1576    -----------------------------
1577    -- Warn_On_Known_Condition --
1578    -----------------------------
1579
1580    procedure Warn_On_Known_Condition (C : Node_Id) is
1581       P : Node_Id;
1582
1583    begin
1584       --   Argument replacement in an inlined body can make conditions
1585       --   static. Do not emit warnings in this case.
1586
1587       if In_Inlined_Body then
1588          return;
1589       end if;
1590
1591       if Constant_Condition_Warnings
1592         and then Nkind (C) = N_Identifier
1593         and then
1594           (Entity (C) = Standard_False or else Entity (C) = Standard_True)
1595         and then Comes_From_Source (Original_Node (C))
1596         and then not In_Instance
1597       then
1598          --  See if this is in a statement or a declaration
1599
1600          P := Parent (C);
1601          loop
1602             --  If tree is not attached, do not issue warning (this is very
1603             --  peculiar, and probably arises from some other error condition)
1604
1605             if No (P) then
1606                return;
1607
1608             --  If we are in a declaration, then no warning, since in practice
1609             --  conditionals in declarations are used for intended tests which
1610             --  may be known at compile time, e.g. things like
1611
1612             --    x : constant Integer := 2 + (Word'Size = 32);
1613
1614             --  And a warning is annoying in such cases
1615
1616             elsif Nkind (P) in N_Declaration
1617                     or else
1618                   Nkind (P) in N_Later_Decl_Item
1619             then
1620                return;
1621
1622             --  Don't warn in assert pragma, since presumably tests in such
1623             --  a context are very definitely intended, and might well be
1624             --  known at compile time. Note that we have to test the original
1625             --  node, since assert pragmas get rewritten at analysis time.
1626
1627             elsif Nkind (Original_Node (P)) = N_Pragma
1628               and then Chars (Original_Node (P)) = Name_Assert
1629             then
1630                return;
1631             end if;
1632
1633             exit when Is_Statement (P);
1634             P := Parent (P);
1635          end loop;
1636
1637          --  Here we issue the warning unless some sub-operand has warnings
1638          --  set off, in which case we suppress the warning for the node.
1639
1640          if not Operand_Has_Warnings_Suppressed (C) then
1641             if Entity (C) = Standard_True then
1642                Error_Msg_N ("condition is always True?", C);
1643             else
1644                Error_Msg_N ("condition is always False?", C);
1645             end if;
1646          end if;
1647       end if;
1648    end Warn_On_Known_Condition;
1649
1650 end Sem_Warn;