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-2006, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 Exp_Code; use Exp_Code;
  32 with Fname;    use Fname;
  33 with Lib;      use Lib;
  34 with Namet;    use Namet;
  35 with Nlists;   use Nlists;
  36 with Opt;      use Opt;
  37 with Sem;      use Sem;
  38 with Sem_Ch8;  use Sem_Ch8;
  39 with Sem_Eval; use Sem_Eval;
  40 with Sem_Util; use Sem_Util;
  41 with Sinfo;    use Sinfo;
  42 with Sinput;   use Sinput;
  43 with Snames;   use Snames;
  44 with Stand;    use Stand;
  45 with Stringt;  use Stringt;
  46 with Table;
  47 with Uintp;    use Uintp;
  48
  49 package body Sem_Warn is
  50
  51    --  The following table collects Id's of entities that are potentially
  52    --  unreferenced. See Check_Unset_Reference for further details.
  53
  54    package Unreferenced_Entities is new Table.Table (
  55      Table_Component_Type => Entity_Id,
  56      Table_Index_Type     => Nat,
  57      Table_Low_Bound      => 1,
  58      Table_Initial        => Alloc.Unreferenced_Entities_Initial,
  59      Table_Increment      => Alloc.Unreferenced_Entities_Increment,
  60      Table_Name           => "Unreferenced_Entities");
  61
  62    -----------------------
  63    -- Local Subprograms --
  64    -----------------------
  65
  66    function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean;
  67    --  This returns true if the entity E is declared within a generic package.
  68    --  The point of this is to detect variables which are not assigned within
  69    --  the generic, but might be assigned outside the package for any given
  70    --  instance. These are cases where we leave the warnings to be posted
  71    --  for the instance, when we will know more.
  72
  73    function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean;
  74    --  This function traverses the expression tree represented by the node N
  75    --  and determines if any sub-operand is a reference to an entity for which
  76    --  the Warnings_Off flag is set. True is returned if such an entity is
  77    --  encountered, and False otherwise.
  78
  79    --------------------------
  80    -- Check_Code_Statement --
  81    --------------------------
  82
  83    procedure Check_Code_Statement (N : Node_Id) is
  84    begin
  85       --  If volatile, nothing to worry about
  86
  87       if Is_Asm_Volatile (N) then
  88          return;
  89       end if;
  90
  91       --  Warn if no input or no output
  92
  93       Setup_Asm_Inputs (N);
  94
  95       if No (Asm_Input_Value) then
  96          Error_Msg_F
  97            ("?code statement with no inputs should usually be Volatile", N);
  98          return;
  99       end if;
 100
 101       Setup_Asm_Outputs (N);
 102
 103       if No (Asm_Output_Variable) then
 104          Error_Msg_F
 105            ("?code statement with no outputs should usually be Volatile", N);
 106          return;
 107       end if;
 108
 109       --  Check multiple code statements in a row
 110
 111       if Is_List_Member (N)
 112         and then Present (Prev (N))
 113         and then Nkind (Prev (N)) = N_Code_Statement
 114       then
 115          Error_Msg_F
 116            ("?code statements in sequence should usually be Volatile", N);
 117          Error_Msg_F
 118            ("\?(suggest using template with multiple instructions)", N);
 119       end if;
 120    end Check_Code_Statement;
 121
 122    ----------------------
 123    -- Check_References --
 124    ----------------------
 125
 126    procedure Check_References (E : Entity_Id; Anod : Node_Id := Empty) is
 127       E1 : Entity_Id;
 128       UR : Node_Id;
 129
 130       function Missing_Subunits return Boolean;
 131       --  We suppress warnings when there are missing subunits, because this
 132       --  may generate too many false positives: entities in a parent may only
 133       --  be referenced in one of the subunits. We make an exception for
 134       --  subunits that contain no other stubs.
 135
 136       procedure Output_Reference_Error (M : String);
 137       --  Used to output an error message. Deals with posting the error on the
 138       --  body formal in the accept case.
 139
 140       function Publicly_Referenceable (Ent : Entity_Id) return Boolean;
 141       --  This is true if the entity in question is potentially referenceable
 142       --  from another unit. This is true for entities in packages that are at
 143       --  the library level.
 144
 145       ----------------------
 146       -- Missing_Subunits --
 147       ----------------------
 148
 149       function Missing_Subunits return Boolean is
 150          D : Node_Id;
 151
 152       begin
 153          if not Unloaded_Subunits then
 154
 155             --  Normal compilation, all subunits are present
 156
 157             return False;
 158
 159          elsif E /= Main_Unit_Entity then
 160
 161             --  No warnings on a stub that is not the main unit
 162
 163             return True;
 164
 165          elsif Nkind (Unit_Declaration_Node (E)) in N_Proper_Body then
 166             D := First (Declarations (Unit_Declaration_Node (E)));
 167             while Present (D) loop
 168
 169                --  No warnings if the proper body contains nested stubs
 170
 171                if Nkind (D) in N_Body_Stub then
 172                   return True;
 173                end if;
 174
 175                Next (D);
 176             end loop;
 177
 178             return False;
 179
 180          else
 181             --  Missing stubs elsewhere
 182
 183             return True;
 184          end if;
 185       end Missing_Subunits;
 186
 187       ----------------------------
 188       -- Output_Reference_Error --
 189       ----------------------------
 190
 191       procedure Output_Reference_Error (M : String) is
 192       begin
 193          --  Other than accept case, post error on defining identifier
 194
 195          if No (Anod) then
 196             Error_Msg_N (M, E1);
 197
 198          --  Accept case, find body formal to post the message
 199
 200          else
 201             declare
 202                Parm  : Node_Id;
 203                Enod  : Node_Id;
 204                Defid : Entity_Id;
 205
 206             begin
 207                Enod := Anod;
 208
 209                if Present (Parameter_Specifications (Anod)) then
 210                   Parm := First (Parameter_Specifications (Anod));
 211                   while Present (Parm) loop
 212                      Defid := Defining_Identifier (Parm);
 213
 214                      if Chars (E1) = Chars (Defid) then
 215                         Enod := Defid;
 216                         exit;
 217                      end if;
 218
 219                      Next (Parm);
 220                   end loop;
 221                end if;
 222
 223                Error_Msg_NE (M, Enod, E1);
 224             end;
 225          end if;
 226       end Output_Reference_Error;
 227
 228       ----------------------------
 229       -- Publicly_Referenceable --
 230       ----------------------------
 231
 232       function Publicly_Referenceable (Ent : Entity_Id) return Boolean is
 233          P    : Node_Id;
 234          Prev : Node_Id;
 235
 236       begin
 237          --  Examine parents to look for a library level package spec. But if
 238          --  we find a body or block or other similar construct along the way,
 239          --  we cannot be referenced.
 240
 241          Prev := Ent;
 242          P    := Parent (Ent);
 243          loop
 244             case Nkind (P) is
 245
 246                --  If we get to top of tree, then publicly referenceable
 247
 248                when N_Empty =>
 249                   return True;
 250
 251                --  If we reach a generic package declaration, then always
 252                --  consider this referenceable, since any instantiation will
 253                --  have access to the entities in the generic package. Note
 254                --  that the package itself may not be instantiated, but then
 255                --  we will get a warning for the package entity.
 256
 257                --  Note that generic formal parameters are themselves not
 258                --  publicly referenceable in an instance, and warnings on
 259                --  them are useful.
 260
 261                when N_Generic_Package_Declaration =>
 262                   return
 263                     not Is_List_Member (Prev)
 264                       or else List_Containing (Prev)
 265                         /= Generic_Formal_Declarations (P);
 266
 267                --  Similarly, the generic formals of a generic subprogram
 268                --  are not accessible.
 269
 270                when N_Generic_Subprogram_Declaration  =>
 271                   if Is_List_Member (Prev)
 272                     and then List_Containing (Prev) =
 273                                Generic_Formal_Declarations (P)
 274                   then
 275                      return False;
 276                   else
 277                      P := Parent (P);
 278                   end if;
 279
 280                --  If we reach a subprogram body, entity is not referenceable
 281                --  unless it is the defining entity of the body. This will
 282                --  happen, e.g. when a function is an attribute renaming that
 283                --  is rewritten as a body.
 284
 285                when N_Subprogram_Body  =>
 286                   if Ent /= Defining_Entity (P) then
 287                      return False;
 288                   else
 289                      P := Parent (P);
 290                   end if;
 291
 292                --  If we reach any other body, definitely not referenceable
 293
 294                when N_Package_Body    |
 295                     N_Task_Body       |
 296                     N_Entry_Body      |
 297                     N_Protected_Body  |
 298                     N_Block_Statement |
 299                     N_Subunit         =>
 300                   return False;
 301
 302                --  For all other cases, keep looking up tree
 303
 304                when others =>
 305                   Prev := P;
 306                   P    := Parent (P);
 307             end case;
 308          end loop;
 309       end Publicly_Referenceable;
 310
 311    --  Start of processing for Check_References
 312
 313    begin
 314       --  No messages if warnings are suppressed, or if we have detected any
 315       --  real errors so far (this last check avoids junk messages resulting
 316       --  from errors, e.g. a subunit that is not loaded).
 317
 318       if Warning_Mode = Suppress
 319         or else Serious_Errors_Detected /= 0
 320       then
 321          return;
 322       end if;
 323
 324       --  We also skip the messages if any subunits were not loaded (see
 325       --  comment in Sem_Ch10 to understand how this is set, and why it is
 326       --  necessary to suppress the warnings in this case).
 327
 328       if Missing_Subunits then
 329          return;
 330       end if;
 331
 332       --  Otherwise loop through entities, looking for suspicious stuff
 333
 334       E1 := First_Entity (E);
 335       while Present (E1) loop
 336
 337          --  We only look at source entities with warning flag on
 338
 339          if Comes_From_Source (E1) and then not Warnings_Off (E1) then
 340
 341             --  We are interested in variables and out parameters, but we
 342             --  exclude protected types, too complicated to worry about.
 343
 344             if Ekind (E1) = E_Variable
 345                  or else
 346                (Ekind (E1) = E_Out_Parameter
 347                   and then not Is_Protected_Type (Current_Scope))
 348             then
 349                --  Post warning if this object not assigned. Note that we do
 350                --  not consider the implicit initialization of an access type
 351                --  to be the assignment of a value for this purpose.
 352
 353                if Ekind (E1) = E_Out_Parameter
 354                  and then Present (Spec_Entity (E1))
 355                then
 356                   UR := Unset_Reference (Spec_Entity (E1));
 357                else
 358                   UR := Unset_Reference (E1);
 359                end if;
 360
 361                --  If the entity is an out parameter of the current subprogram
 362                --  body, check the warning status of the parameter in the spec.
 363
 364                if Ekind (E1) = E_Out_Parameter
 365                  and then Present (Spec_Entity (E1))
 366                  and then Warnings_Off (Spec_Entity (E1))
 367                then
 368                   null;
 369
 370                elsif Present (UR)
 371                  and then Is_Access_Type (Etype (E1))
 372                then
 373
 374                   --  For access types, the only time we made a UR entry was
 375                   --  for a dereference, and so we post the appropriate warning
 376                   --  here (note that the dereference may not be explicit in
 377                   --  the source, for example in the case of a dispatching call
 378                   --  with an anonymous access controlling formal, or of an
 379                   --  assignment of a pointer involving discriminant check on
 380                   --  the designated object).
 381
 382                   Error_Msg_NE ("& may be null?", UR, E1);
 383                   goto Continue;
 384
 385                elsif Never_Set_In_Source (E1)
 386                  and then not Generic_Package_Spec_Entity (E1)
 387                then
 388                   if Warn_On_No_Value_Assigned then
 389
 390                      --  Do not output complaint about never being assigned a
 391                      --  value if a pragma Unreferenced applies to the variable
 392                      --  or if it is a parameter, to the corresponding spec.
 393
 394                      if Has_Pragma_Unreferenced (E1)
 395                        or else (Is_Formal (E1)
 396                                   and then Present (Spec_Entity (E1))
 397                                   and then
 398                                     Has_Pragma_Unreferenced (Spec_Entity (E1)))
 399                      then
 400                         null;
 401
 402                      --  Pragma Unreferenced not set, so output message
 403
 404                      else
 405                         if Referenced (E1) then
 406                            Output_Reference_Error
 407                              ("variable& is read but never assigned?");
 408                         else
 409                            Output_Reference_Error
 410                              ("variable& is never read and never assigned?");
 411                         end if;
 412
 413                         --  Deal with special case where this variable is
 414                         --  hidden by a loop variable
 415
 416                         if Ekind (E1) = E_Variable
 417                           and then Present (Hiding_Loop_Variable (E1))
 418                         then
 419                            Error_Msg_Sloc := Sloc (E1);
 420                            Error_Msg_N
 421                              ("declaration hides &#?",
 422                               Hiding_Loop_Variable (E1));
 423                            Error_Msg_N
 424                              ("for loop implicitly declares loop variable?",
 425                               Hiding_Loop_Variable (E1));
 426                         end if;
 427                      end if;
 428                   end if;
 429                   goto Continue;
 430
 431                --  Case of variable that could be a constant. Note that we
 432                --  never signal such messages for generic package entities,
 433                --  since a given instance could have modifications outside
 434                --  the package.
 435
 436                elsif Warn_On_Constant
 437                  and then Ekind (E1) = E_Variable
 438                  and then Is_True_Constant (E1)
 439                  and then not Generic_Package_Spec_Entity (E1)
 440                then
 441                   --  A special case, if this variable is volatile and not
 442                   --  imported, it is not helpful to tell the programmer
 443                   --  to mark the variable as constant, since this would be
 444                   --  illegal by virtue of RM C.6(13).
 445
 446                   if (Is_Volatile (E1) or else Has_Volatile_Components (E1))
 447                     and then not Is_Imported (E1)
 448                   then
 449                      Error_Msg_N
 450                        ("& is not modified, volatile has no effect?", E1);
 451                   else
 452                      Error_Msg_N
 453                        ("& is not modified, could be declared constant?", E1);
 454                   end if;
 455                end if;
 456
 457                --  Check for unset reference, note that we exclude access
 458                --  types from this check, since access types do always have
 459                --  a null value, and that seems legitimate in this case.
 460
 461                if Warn_On_No_Value_Assigned and then Present (UR) then
 462
 463                   --  For other than access type, go back to original node
 464                   --  to deal with case where original unset reference
 465                   --  has been rewritten during expansion.
 466
 467                   UR := Original_Node (UR);
 468
 469                   --  In some cases, the original node may be a type
 470                   --  conversion or qualification, and in this case
 471                   --  we want the object entity inside.
 472
 473                   while Nkind (UR) = N_Type_Conversion
 474                     or else Nkind (UR) = N_Qualified_Expression
 475                   loop
 476                      UR := Expression (UR);
 477                   end loop;
 478
 479                   --  Here we issue the warning, all checks completed If the
 480                   --  unset reference is prefix of a selected component that
 481                   --  comes from source, mention the component as well. If the
 482                   --  selected component comes from expansion, all we know is
 483                   --  that the entity is not fully initialized at the point of
 484                   --  the reference. Locate an unintialized component to get a
 485                   --  better error message.
 486
 487                   if Nkind (Parent (UR)) = N_Selected_Component then
 488                      Error_Msg_Node_2 := Selector_Name (Parent (UR));
 489
 490                      if not Comes_From_Source (Parent (UR)) then
 491                         declare
 492                            Comp : Entity_Id;
 493
 494                         begin
 495                            Comp := First_Entity (Etype (E1));
 496                            while Present (Comp) loop
 497                               if Ekind (Comp) = E_Component
 498                                 and then Nkind (Parent (Comp)) =
 499                                   N_Component_Declaration
 500                                 and then No (Expression (Parent (Comp)))
 501                               then
 502                                  Error_Msg_Node_2 := Comp;
 503                                  exit;
 504                               end if;
 505
 506                               Next_Entity (Comp);
 507                            end loop;
 508                         end;
 509                      end if;
 510
 511                      Error_Msg_N
 512                        ("`&.&` may be referenced before it has a value?",
 513                         UR);
 514                   else
 515                      Error_Msg_N
 516                        ("& may be referenced before it has a value?",
 517                         UR);
 518                   end if;
 519
 520                   goto Continue;
 521                end if;
 522             end if;
 523
 524             --  Then check for unreferenced entities. Note that we are only
 525             --  interested in entities which do not have the Referenced flag
 526             --  set. The Referenced_As_LHS flag is interesting only if the
 527             --  Referenced flag is not set.
 528
 529             if not Referenced (E1)
 530
 531                --  Check that warnings on unreferenced entities are enabled
 532
 533               and then ((Check_Unreferenced and then not Is_Formal (E1))
 534                            or else
 535                         (Check_Unreferenced_Formals and then Is_Formal (E1))
 536                            or else
 537                         (Warn_On_Modified_Unread
 538                           and then Referenced_As_LHS (E1)))
 539
 540                --  Labels, and enumeration literals, and exceptions. The
 541                --  warnings are also placed on local packages that cannot be
 542                --  referenced from elsewhere, including those declared within a
 543                --  package body.
 544
 545                and then (Is_Object (E1)
 546                            or else
 547                          Is_Type (E1)
 548                            or else
 549                          Ekind (E1) = E_Label
 550                            or else
 551                          Ekind (E1) = E_Exception
 552                            or else
 553                          Ekind (E1) = E_Named_Integer
 554                            or else
 555                          Ekind (E1) = E_Named_Real
 556                            or else
 557                          Is_Overloadable (E1)
 558                            or else
 559                              (Ekind (E1) = E_Package
 560                                and then
 561                                 (Ekind (E) = E_Function
 562                                   or else Ekind (E) = E_Package_Body
 563                                   or else Ekind (E) = E_Procedure
 564                                   or else Ekind (E) = E_Subprogram_Body
 565                                   or else Ekind (E) = E_Block)))
 566
 567                --  Exclude instantiations, since there is no reason why every
 568                --  entity in an instantiation should be referenced.
 569
 570                and then Instantiation_Location (Sloc (E1)) = No_Location
 571
 572                --  Exclude formal parameters from bodies if the corresponding
 573                --  spec entity has been referenced in the case where there is
 574                --  a separate spec.
 575
 576                and then not (Is_Formal (E1)
 577                                and then
 578                              Ekind (Scope (E1)) = E_Subprogram_Body
 579                                and then
 580                              Present (Spec_Entity (E1))
 581                                and then
 582                              Referenced (Spec_Entity (E1)))
 583
 584                --  Consider private type referenced if full view is referenced
 585                --  If there is not full view, this is a generic type on which
 586                --  warnings are also useful.
 587
 588                and then
 589                  not (Is_Private_Type (E1)
 590                    and then
 591                      Present (Full_View (E1))
 592                        and then Referenced (Full_View (E1)))
 593
 594                --  Don't worry about full view, only about private type
 595
 596                and then not Has_Private_Declaration (E1)
 597
 598                --  Eliminate dispatching operations from consideration, we
 599                --  cannot tell if these are referenced or not in any easy
 600                --  manner (note this also catches Adjust/Finalize/Initialize)
 601
 602                and then not Is_Dispatching_Operation (E1)
 603
 604                --  Check entity that can be publicly referenced (we do not give
 605                --  messages for such entities, since there could be other
 606                --  units, not involved in this compilation, that contain
 607                --  relevant references.
 608
 609                and then not Publicly_Referenceable (E1)
 610
 611                --  Class wide types are marked as source entities, but they are
 612                --  not really source entities, and are always created, so we do
 613                --  not care if they are not referenced.
 614
 615                and then Ekind (E1) /= E_Class_Wide_Type
 616
 617                --  Objects other than parameters of task types are allowed to
 618                --  be non-referenced, since they start up tasks!
 619
 620                and then ((Ekind (E1) /= E_Variable
 621                              and then Ekind (E1) /= E_Constant
 622                              and then Ekind (E1) /= E_Component)
 623                            or else not Is_Task_Type (Etype (E1)))
 624
 625                --  For subunits, only place warnings on the main unit itself,
 626                --  since parent units are not completely compiled
 627
 628                and then (Nkind (Unit (Cunit (Main_Unit))) /= N_Subunit
 629                            or else
 630                          Get_Source_Unit (E1) = Main_Unit)
 631             then
 632                --  Suppress warnings in internal units if not in -gnatg mode
 633                --  (these would be junk warnings for an applications program,
 634                --  since they refer to problems in internal units)
 635
 636                if GNAT_Mode
 637                  or else not
 638                    Is_Internal_File_Name
 639                      (Unit_File_Name (Get_Source_Unit (E1)))
 640                then
 641                   --  We do not immediately flag the error. This is because we
 642                   --  have not expanded generic bodies yet, and they may have
 643                   --  the missing reference. So instead we park the entity on a
 644                   --  list, for later processing. However, for the accept case,
 645                   --  post the error right here, since we have the information
 646                   --  now in this case.
 647
 648                   if Present (Anod) then
 649                      Output_Reference_Error ("& is not referenced?");
 650
 651                   else
 652                      Unreferenced_Entities.Increment_Last;
 653                      Unreferenced_Entities.Table
 654                        (Unreferenced_Entities.Last) := E1;
 655                   end if;
 656                end if;
 657
 658             --  Generic units are referenced in the generic body, but if they
 659             --  are not public and never instantiated we want to force a
 660             --  warning on them. We treat them as redundant constructs to
 661             --  minimize noise.
 662
 663             elsif Is_Generic_Subprogram (E1)
 664               and then not Is_Instantiated (E1)
 665               and then not Publicly_Referenceable (E1)
 666               and then Instantiation_Depth (Sloc (E1)) = 0
 667               and then Warn_On_Redundant_Constructs
 668             then
 669                Unreferenced_Entities.Increment_Last;
 670                Unreferenced_Entities.Table (Unreferenced_Entities.Last) := E1;
 671
 672                --  Force warning on entity
 673
 674                Set_Referenced (E1, False);
 675             end if;
 676          end if;
 677
 678          --  Recurse into nested package or block. Do not recurse into a
 679          --  formal package, because the correponding body is not analyzed.
 680
 681          <<Continue>>
 682             if ((Ekind (E1) = E_Package or else Ekind (E1) = E_Generic_Package)
 683                   and then Nkind (Parent (E1)) = N_Package_Specification
 684                   and then
 685                     Nkind (Original_Node (Unit_Declaration_Node (E1)))
 686                       /= N_Formal_Package_Declaration)
 687
 688               or else Ekind (E1) = E_Block
 689             then
 690                Check_References (E1);
 691             end if;
 692
 693             Next_Entity (E1);
 694       end loop;
 695    end Check_References;
 696
 697    ---------------------------
 698    -- Check_Unset_Reference --
 699    ---------------------------
 700
 701    procedure Check_Unset_Reference (N : Node_Id) is
 702    begin
 703       --  Nothing to do if warnings suppressed
 704
 705       if Warning_Mode = Suppress then
 706          return;
 707       end if;
 708
 709       --  Ignore reference to non-scalar if not from source. Almost always such
 710       --  references are bogus (e.g. calls to init procs to set default
 711       --  discriminant values).
 712
 713       if not Comes_From_Source (N)
 714         and then not Is_Scalar_Type (Etype (N))
 715       then
 716          return;
 717       end if;
 718
 719       --  Otherwise see what kind of node we have. If the entity already
 720       --  has an unset reference, it is not necessarily the earliest in
 721       --  the text, because resolution of the prefix of selected components
 722       --  is completed before the resolution of the selected component itself.
 723       --  as a result, given  (R /= null and then R.X > 0), the occurrences
 724       --  of R are examined in right-to-left order. If there is already an
 725       --  unset reference, we check whether N is earlier before proceeding.
 726
 727       case Nkind (N) is
 728          when N_Identifier | N_Expanded_Name =>
 729             declare
 730                E : constant Entity_Id := Entity (N);
 731
 732             begin
 733                if (Ekind (E) = E_Variable
 734                     or else Ekind (E) = E_Out_Parameter)
 735                  and then Never_Set_In_Source (E)
 736                  and then (No (Unset_Reference (E))
 737                              or else Earlier_In_Extended_Unit
 738                                (Sloc (N),  Sloc (Unset_Reference (E))))
 739                  and then not Warnings_Off (E)
 740                then
 741                   --  We may have an unset reference. The first test is whether
 742                   --  we are accessing a discriminant of a record or a
 743                   --  component with default initialization. Both of these
 744                   --  cases can be ignored, since the actual object that is
 745                   --  referenced is definitely initialized. Note that this
 746                   --  covers the case of reading discriminants of an out
 747                   --  parameter, which is OK even in Ada 83.
 748
 749                   --  Note that we are only interested in a direct reference to
 750                   --  a record component here. If the reference is via an
 751                   --  access type, then the access object is being referenced,
 752                   --  not the record, and still deserves an unset reference.
 753
 754                   if Nkind (Parent (N)) = N_Selected_Component
 755                     and not Is_Access_Type (Etype (N))
 756                   then
 757                      declare
 758                         ES : constant Entity_Id :=
 759                                Entity (Selector_Name (Parent (N)));
 760
 761                      begin
 762                         if Ekind (ES) = E_Discriminant
 763                           or else Present (Expression (Declaration_Node (ES)))
 764                         then
 765                            return;
 766                         end if;
 767                      end;
 768                   end if;
 769
 770                   --  Here we have a potential unset reference. But before we
 771                   --  get worried about it, we have to make sure that the
 772                   --  entity declaration is in the same procedure as the
 773                   --  reference, since if they are in separate procedures, then
 774                   --  we have no idea about sequential execution.
 775
 776                   --  The tests in the loop below catch all such cases, but do
 777                   --  allow the reference to appear in a loop, block, or
 778                   --  package spec that is nested within the declaring scope.
 779                   --  As always, it is possible to construct cases where the
 780                   --  warning is wrong, that is why it is a warning!
 781
 782                   declare
 783                      SR : Entity_Id;
 784                      SE : constant Entity_Id := Scope (E);
 785
 786                   begin
 787                      SR := Current_Scope;
 788                      while SR /= SE loop
 789                         if SR = Standard_Standard
 790                           or else Is_Subprogram (SR)
 791                           or else Is_Concurrent_Body (SR)
 792                           or else Is_Concurrent_Type (SR)
 793                         then
 794                            return;
 795                         end if;
 796
 797                         SR := Scope (SR);
 798                      end loop;
 799
 800                      --  Case of reference has an access type. This is special
 801                      --  case since access types are always set to null so
 802                      --  cannot be truly uninitialized, but we still want to
 803                      --  warn about cases of obvious null dereference.
 804
 805                      if Is_Access_Type (Etype (N)) then
 806                         Access_Type_Case : declare
 807                            P : Node_Id;
 808
 809                            function Process
 810                              (N    : Node_Id)
 811                               return Traverse_Result;
 812                            --  Process function for instantation of Traverse
 813                            --  below. Checks if N contains reference to other
 814                            --  than a dereference.
 815
 816                            function Ref_In (Nod : Node_Id) return Boolean;
 817                            --  Determines whether Nod contains a reference to
 818                            --  the entity E that is not a dereference.
 819
 820                            -------------
 821                            -- Process --
 822                            -------------
 823
 824                            function Process
 825                              (N    : Node_Id)
 826                               return Traverse_Result
 827                            is
 828                            begin
 829                               if Is_Entity_Name (N)
 830                                 and then Entity (N) = E
 831                                 and then not Is_Dereferenced (N)
 832                               then
 833                                  return Abandon;
 834                               else
 835                                  return OK;
 836                               end if;
 837                            end Process;
 838
 839                            ------------
 840                            -- Ref_In --
 841                            ------------
 842
 843                            function Ref_In (Nod : Node_Id) return Boolean is
 844                               function Traverse is new Traverse_Func (Process);
 845                            begin
 846                               return Traverse (Nod) = Abandon;
 847                            end Ref_In;
 848
 849                         --  Start of processing for Access_Type_Case
 850
 851                         begin
 852                            --  Don't bother if we are inside an instance,
 853                            --  since the compilation of the generic template
 854                            --  is where the warning should be issued.
 855
 856                            if In_Instance then
 857                               return;
 858                            end if;
 859
 860                            --  Don't bother if this is not the main unit.
 861                            --  If we try to give this warning for with'ed
 862                            --  units, we get some false positives, since
 863                            --  we do not record references in other units.
 864
 865                            if not In_Extended_Main_Source_Unit (E)
 866                                 or else
 867                               not In_Extended_Main_Source_Unit (N)
 868                            then
 869                               return;
 870                            end if;
 871
 872                            --  We are only interested in deferences
 873
 874                            if not Is_Dereferenced (N) then
 875                               return;
 876                            end if;
 877
 878                            --  One more check, don't bother with references
 879                            --  that are inside conditional statements or while
 880                            --  loops if the condition references the entity in
 881                            --  question. This avoids most false positives.
 882
 883                            P := Parent (N);
 884                            loop
 885                               P := Parent (P);
 886                               exit when No (P);
 887
 888                               if (Nkind (P) = N_If_Statement
 889                                      or else
 890                                    Nkind (P) = N_Elsif_Part)
 891                                  and then Ref_In (Condition (P))
 892                               then
 893                                  return;
 894
 895                               elsif Nkind (P) = N_Loop_Statement
 896                                 and then Present (Iteration_Scheme (P))
 897                                 and then
 898                                   Ref_In (Condition (Iteration_Scheme (P)))
 899                               then
 900                                  return;
 901                               end if;
 902                            end loop;
 903                         end Access_Type_Case;
 904                      end if;
 905
 906                      --  Here we definitely have a case for giving a warning
 907                      --  for a reference to an unset value. But we don't give
 908                      --  the warning now. Instead we set the Unset_Reference
 909                      --  field of the identifier involved. The reason for this
 910                      --  is that if we find the variable is never ever assigned
 911                      --  a value then that warning is more important and there
 912                      --  is no point in giving the reference warning.
 913
 914                      --  If this is an identifier, set the field directly
 915
 916                      if Nkind (N) = N_Identifier then
 917                         Set_Unset_Reference (E, N);
 918
 919                      --  Otherwise it is an expanded name, so set the field
 920                      --  of the actual identifier for the reference.
 921
 922                      else
 923                         Set_Unset_Reference (E, Selector_Name (N));
 924                      end if;
 925                   end;
 926                end if;
 927             end;
 928
 929          when N_Indexed_Component | N_Slice =>
 930             Check_Unset_Reference (Prefix (N));
 931
 932          when N_Selected_Component =>
 933
 934             if Present (Entity (Selector_Name (N)))
 935               and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
 936             then
 937                --   A discriminant is always initialized
 938
 939                null;
 940
 941             else
 942                Check_Unset_Reference (Prefix (N));
 943             end if;
 944
 945          when N_Type_Conversion | N_Qualified_Expression =>
 946             Check_Unset_Reference (Expression (N));
 947
 948          when others =>
 949             null;
 950
 951       end case;
 952    end Check_Unset_Reference;
 953
 954    ------------------------
 955    -- Check_Unused_Withs --
 956    ------------------------
 957
 958    procedure Check_Unused_Withs (Spec_Unit : Unit_Number_Type := No_Unit) is
 959       Cnode : Node_Id;
 960       Item  : Node_Id;
 961       Lunit : Node_Id;
 962       Ent   : Entity_Id;
 963
 964       Munite : constant Entity_Id := Cunit_Entity (Main_Unit);
 965       --  This is needed for checking the special renaming case
 966
 967       procedure Check_One_Unit (Unit : Unit_Number_Type);
 968       --  Subsidiary procedure, performs checks for specified unit
 969
 970       --------------------
 971       -- Check_One_Unit --
 972       --------------------
 973
 974       procedure Check_One_Unit (Unit : Unit_Number_Type) is
 975          Is_Visible_Renaming : Boolean := False;
 976          Pack                : Entity_Id;
 977
 978          procedure Check_Inner_Package (Pack : Entity_Id);
 979          --  Pack is a package local to a unit in a with_clause. Both the
 980          --  unit and Pack are referenced. If none of the entities in Pack
 981          --  are referenced, then the only occurrence of Pack is in a use
 982          --  clause or a pragma, and a warning is worthwhile as well.
 983
 984          function Check_System_Aux return Boolean;
 985          --  Before giving a warning on a with_clause for System, check
 986          --  whether a system extension is present.
 987
 988          function Find_Package_Renaming
 989            (P : Entity_Id;
 990             L : Entity_Id) return Entity_Id;
 991          --  The only reference to a context unit may be in a renaming
 992          --  declaration. If this renaming declares a visible entity, do
 993          --  not warn that the context clause could be moved to the body,
 994          --  because the renaming may be intented to re-export the unit.
 995
 996          -------------------------
 997          -- Check_Inner_Package --
 998          -------------------------
 999
1000          procedure Check_Inner_Package (Pack : Entity_Id) is
1001             E  : Entity_Id;
1002             Un : constant Node_Id := Sinfo.Unit (Cnode);
1003
1004             function Check_Use_Clause (N : Node_Id) return Traverse_Result;
1005             --  If N is a use_clause for Pack, emit warning
1006
1007             procedure Check_Use_Clauses is new
1008               Traverse_Proc (Check_Use_Clause);
1009
1010             ----------------------
1011             -- Check_Use_Clause --
1012             ----------------------
1013
1014             function Check_Use_Clause (N : Node_Id) return Traverse_Result is
1015                Nam  : Node_Id;
1016
1017             begin
1018                if Nkind (N) = N_Use_Package_Clause then
1019                   Nam := First (Names (N));
1020                   while Present (Nam) loop
1021                      if Entity (Nam) = Pack then
1022                         Error_Msg_Qual_Level := 1;
1023                         Error_Msg_NE
1024                           ("no entities of package& are referenced?",
1025                              Nam, Pack);
1026                         Error_Msg_Qual_Level := 0;
1027                      end if;
1028
1029                      Next (Nam);
1030                   end loop;
1031                end if;
1032
1033                return OK;
1034             end Check_Use_Clause;
1035
1036          --  Start of processing for Check_Inner_Package
1037
1038          begin
1039             E := First_Entity (Pack);
1040             while Present (E) loop
1041                if Referenced (E) then
1042                   return;
1043                end if;
1044
1045                Next_Entity (E);
1046             end loop;
1047
1048             --  No entities of the package are referenced. Check whether the
1049             --  reference to the package itself is a use clause, and if so
1050             --  place a warning on it.
1051
1052             Check_Use_Clauses (Un);
1053          end Check_Inner_Package;
1054
1055          ----------------------
1056          -- Check_System_Aux --
1057          ----------------------
1058
1059          function Check_System_Aux return Boolean is
1060             Ent : Entity_Id;
1061
1062          begin
1063             if Chars (Lunit) = Name_System
1064                and then Scope (Lunit) = Standard_Standard
1065                and then Present_System_Aux
1066             then
1067                Ent := First_Entity (System_Aux_Id);
1068                while Present (Ent) loop
1069                   if Referenced (Ent) then
1070                      return True;
1071                   end if;
1072
1073                   Next_Entity (Ent);
1074                end loop;
1075             end if;
1076
1077             return False;
1078          end Check_System_Aux;
1079
1080          ---------------------------
1081          -- Find_Package_Renaming --
1082          ---------------------------
1083
1084          function Find_Package_Renaming
1085            (P : Entity_Id;
1086             L : Entity_Id) return Entity_Id
1087          is
1088             E1 : Entity_Id;
1089             R  : Entity_Id;
1090
1091          begin
1092             Is_Visible_Renaming := False;
1093
1094             E1 := First_Entity (P);
1095             while Present (E1) loop
1096                if Ekind (E1) = E_Package
1097                   and then Renamed_Object (E1) = L
1098                then
1099                   Is_Visible_Renaming := not Is_Hidden (E1);
1100                   return E1;
1101
1102                elsif Ekind (E1) = E_Package
1103                  and then No (Renamed_Object (E1))
1104                  and then not Is_Generic_Instance (E1)
1105                then
1106                   R := Find_Package_Renaming (E1, L);
1107
1108                   if Present (R) then
1109                      Is_Visible_Renaming := not Is_Hidden (R);
1110                      return R;
1111                   end if;
1112                end if;
1113
1114                Next_Entity (E1);
1115             end loop;
1116
1117             return Empty;
1118          end Find_Package_Renaming;
1119
1120       --  Start of processing for Check_One_Unit
1121
1122       begin
1123          Cnode := Cunit (Unit);
1124
1125          --  Only do check in units that are part of the extended main unit.
1126          --  This is actually a necessary restriction, because in the case of
1127          --  subprogram acting as its own specification, there can be with's in
1128          --  subunits that we will not see.
1129
1130          if not In_Extended_Main_Source_Unit (Cnode) then
1131             return;
1132
1133          --  In configurable run time mode, we remove the bodies of non-inlined
1134          --  subprograms, which may lead to spurious warnings, which are
1135          --  clearly undesirable.
1136
1137          elsif Configurable_Run_Time_Mode
1138            and then Is_Predefined_File_Name (Unit_File_Name (Unit))
1139          then
1140             return;
1141          end if;
1142
1143          --  Loop through context items in this unit
1144
1145          Item := First (Context_Items (Cnode));
1146          while Present (Item) loop
1147             if Nkind (Item) = N_With_Clause
1148                and then not Implicit_With (Item)
1149                and then In_Extended_Main_Source_Unit (Item)
1150             then
1151                Lunit := Entity (Name (Item));
1152
1153                --  Check if this unit is referenced (skip the check if this
1154                --  is explicitly marked by a pragma Unreferenced).
1155
1156                if not Referenced (Lunit)
1157                  and then not Has_Pragma_Unreferenced (Lunit)
1158                then
1159                   --  Suppress warnings in internal units if not in -gnatg mode
1160                   --  (these would be junk warnings for an application program,
1161                   --  since they refer to problems in internal units).
1162
1163                   if GNAT_Mode
1164                     or else not Is_Internal_File_Name (Unit_File_Name (Unit))
1165                   then
1166                      --  Here we definitely have a non-referenced unit. If it
1167                      --  is the special call for a spec unit, then just set the
1168                      --  flag to be read later.
1169
1170                      if Unit = Spec_Unit then
1171                         Set_Unreferenced_In_Spec (Item);
1172
1173                      --  Otherwise simple unreferenced message
1174
1175                      else
1176                         Error_Msg_N
1177                           ("unit& is not referenced?", Name (Item));
1178                      end if;
1179                   end if;
1180
1181                --  If main unit is a renaming of this unit, then we consider
1182                --  the with to be OK (obviously it is needed in this case!)
1183                --  This may be transitive: the unit in the with_clause may
1184                --  itself be a renaming, in which case both it and the main
1185                --  unit rename the same ultimate package.
1186
1187                elsif Present (Renamed_Entity (Munite))
1188                   and then
1189                     (Renamed_Entity (Munite) = Lunit
1190                       or else Renamed_Entity (Munite) = Renamed_Entity (Lunit))
1191                then
1192                   null;
1193
1194                --  If this unit is referenced, and it is a package, we do
1195                --  another test, to see if any of the entities in the package
1196                --  are referenced. If none of the entities are referenced, we
1197                --  still post a warning. This occurs if the only use of the
1198                --  package is in a use clause, or in a package renaming
1199                --  declaration.
1200
1201                elsif Ekind (Lunit) = E_Package then
1202
1203                   --  If Is_Instantiated is set, it means that the package is
1204                   --  implicitly instantiated (this is the case of parent
1205                   --  instance or an actual for a generic package formal), and
1206                   --  this counts as a reference.
1207
1208                   if Is_Instantiated (Lunit) then
1209                      null;
1210
1211                   --  If no entities in package, and there is a pragma
1212                   --  Elaborate_Body present, then assume that this with is
1213                   --  done for purposes of this elaboration.
1214
1215                   elsif No (First_Entity (Lunit))
1216                     and then Has_Pragma_Elaborate_Body (Lunit)
1217                   then
1218                      null;
1219
1220                   --  Otherwise see if any entities have been referenced
1221
1222                   else
1223                      if Limited_Present (Item) then
1224                         Ent := First_Entity (Limited_View (Lunit));
1225                      else
1226                         Ent := First_Entity (Lunit);
1227                      end if;
1228
1229                      loop
1230                         --  No more entities, and we did not find one that was
1231                         --  referenced. Means we have a definite case of a with
1232                         --  none of whose entities was referenced.
1233
1234                         if No (Ent) then
1235
1236                            --  If in spec, just set the flag
1237
1238                            if Unit = Spec_Unit then
1239                               Set_No_Entities_Ref_In_Spec (Item);
1240
1241                            elsif Check_System_Aux then
1242                               null;
1243
1244                            --  Else give the warning
1245
1246                            else
1247                               Error_Msg_N
1248                                 ("no entities of & are referenced?",
1249                                  Name (Item));
1250
1251                               --  Look for renamings of this package, and flag
1252                               --  them as well. If the original package has
1253                               --  warnings off, we suppress the warning on the
1254                               --  renaming as well.
1255
1256                               Pack := Find_Package_Renaming (Munite, Lunit);
1257
1258                               if Present (Pack)
1259                                 and then not Warnings_Off (Lunit)
1260                               then
1261                                  Error_Msg_NE
1262                                    ("no entities of & are referenced?",
1263                                      Unit_Declaration_Node (Pack),
1264                                        Pack);
1265                               end if;
1266                            end if;
1267
1268                            exit;
1269
1270                         --  Case of next entity is referenced
1271
1272                         elsif Referenced (Ent)
1273                           or else Referenced_As_LHS (Ent)
1274                         then
1275                            --  This means that the with is indeed fine, in that
1276                            --  it is definitely needed somewhere, and we can
1277                            --  quit worrying about this one.
1278
1279                            --  Except for one little detail, if either of the
1280                            --  flags was set during spec processing, this is
1281                            --  where we complain that the with could be moved
1282                            --  from the spec. If the spec contains a visible
1283                            --  renaming of the package, inhibit warning to move
1284                            --  with_clause to body.
1285
1286                            if Ekind (Munite) = E_Package_Body then
1287                               Pack :=
1288                                 Find_Package_Renaming
1289                                   (Spec_Entity (Munite), Lunit);
1290                            end if;
1291
1292                            if Unreferenced_In_Spec (Item) then
1293                               Error_Msg_N
1294                                 ("unit& is not referenced in spec?",
1295                                  Name (Item));
1296
1297                            elsif No_Entities_Ref_In_Spec (Item) then
1298                               Error_Msg_N
1299                                 ("no entities of & are referenced in spec?",
1300                                  Name (Item));
1301
1302                            else
1303                               if Ekind (Ent) = E_Package then
1304                                  Check_Inner_Package (Ent);
1305                               end if;
1306
1307                               exit;
1308                            end if;
1309
1310                            if not Is_Visible_Renaming then
1311                               Error_Msg_N
1312                                 ("\with clause might be moved to body?",
1313                                  Name (Item));
1314                            end if;
1315
1316                            exit;
1317
1318                         --  Move to next entity to continue search
1319
1320                         else
1321                            Next_Entity (Ent);
1322                         end if;
1323                      end loop;
1324                   end if;
1325
1326                --  For a generic package, the only interesting kind of
1327                --  reference is an instantiation, since entities cannot be
1328                --  referenced directly.
1329
1330                elsif Is_Generic_Unit (Lunit) then
1331
1332                   --  Unit was never instantiated, set flag for case of spec
1333                   --  call, or give warning for normal call.
1334
1335                   if not Is_Instantiated (Lunit) then
1336                      if Unit = Spec_Unit then
1337                         Set_Unreferenced_In_Spec (Item);
1338                      else
1339                         Error_Msg_N
1340                           ("unit& is never instantiated?", Name (Item));
1341                      end if;
1342
1343                   --  If unit was indeed instantiated, make sure that flag is
1344                   --  not set showing it was uninstantiated in the spec, and if
1345                   --  so, give warning.
1346
1347                   elsif Unreferenced_In_Spec (Item) then
1348                      Error_Msg_N
1349                        ("unit& is not instantiated in spec?", Name (Item));
1350                      Error_Msg_N
1351                        ("\with clause can be moved to body?", Name (Item));
1352                   end if;
1353                end if;
1354             end if;
1355
1356             Next (Item);
1357          end loop;
1358
1359       end Check_One_Unit;
1360
1361    --  Start of processing for Check_Unused_Withs
1362
1363    begin
1364       if not Opt.Check_Withs
1365         or else Operating_Mode = Check_Syntax
1366       then
1367          return;
1368       end if;
1369
1370       --  Flag any unused with clauses, but skip this step if we are compiling
1371       --  a subunit on its own, since we do not have enough information to
1372       --  determine whether with's are used. We will get the relevant warnings
1373       --  when we compile the parent. This is the normal style of GNAT
1374       --  compilation in any case.
1375
1376       if Nkind (Unit (Cunit (Main_Unit))) = N_Subunit then
1377          return;
1378       end if;
1379
1380       --  Process specified units
1381
1382       if Spec_Unit = No_Unit then
1383
1384          --  For main call, check all units
1385
1386          for Unit in Main_Unit .. Last_Unit loop
1387             Check_One_Unit (Unit);
1388          end loop;
1389
1390       else
1391          --  For call for spec, check only the spec
1392
1393          Check_One_Unit (Spec_Unit);
1394       end if;
1395    end Check_Unused_Withs;
1396
1397    ---------------------------------
1398    -- Generic_Package_Spec_Entity --
1399    ---------------------------------
1400
1401    function Generic_Package_Spec_Entity (E : Entity_Id) return Boolean is
1402       S : Entity_Id;
1403
1404    begin
1405       if Is_Package_Body_Entity (E) then
1406          return False;
1407
1408       else
1409          S := Scope (E);
1410          loop
1411             if S = Standard_Standard then
1412                return False;
1413
1414             elsif Ekind (S) = E_Generic_Package then
1415                return True;
1416
1417             elsif Ekind (S) = E_Package then
1418                S := Scope (S);
1419
1420             else
1421                return False;
1422             end if;
1423          end loop;
1424       end if;
1425    end Generic_Package_Spec_Entity;
1426
1427    -------------------------------------
1428    -- Operand_Has_Warnings_Suppressed --
1429    -------------------------------------
1430
1431    function Operand_Has_Warnings_Suppressed (N : Node_Id) return Boolean is
1432
1433       function Check_For_Warnings (N : Node_Id) return Traverse_Result;
1434       --  Function used to check one node to see if it is or was originally
1435       --  a reference to an entity for which Warnings are off. If so, Abandon
1436       --  is returned, otherwise OK_Orig is returned to continue the traversal
1437       --  of the original expression.
1438
1439       function Traverse is new Traverse_Func (Check_For_Warnings);
1440       --  Function used to traverse tree looking for warnings
1441
1442       ------------------------
1443       -- Check_For_Warnings --
1444       ------------------------
1445
1446       function Check_For_Warnings (N : Node_Id) return Traverse_Result is
1447          R : constant Node_Id := Original_Node (N);
1448
1449       begin
1450          if Nkind (R) in N_Has_Entity
1451            and then Present (Entity (R))
1452            and then Warnings_Off (Entity (R))
1453          then
1454             return Abandon;
1455          else
1456             return OK_Orig;
1457          end if;
1458       end Check_For_Warnings;
1459
1460    --  Start of processing for Operand_Has_Warnings_Suppressed
1461
1462    begin
1463       return Traverse (N) = Abandon;
1464
1465    --  If any exception occurs, then something has gone wrong, and this is
1466    --  only a minor aesthetic issue anyway, so just say we did not find what
1467    --  we are looking for, rather than blow up.
1468
1469    exception
1470       when others =>
1471          return False;
1472    end Operand_Has_Warnings_Suppressed;
1473
1474    ----------------------------------------
1475    -- Output_Obsolescent_Entity_Warnings --
1476    ----------------------------------------
1477
1478    procedure Output_Obsolescent_Entity_Warnings (N : Node_Id; E : Entity_Id) is
1479       P : constant Node_Id := Parent (N);
1480       S : Entity_Id;
1481
1482    begin
1483       S := Current_Scope;
1484
1485       --  Do not output message if we are the scope of standard. This means
1486       --  we have a reference from a context clause from when it is originally
1487       --  processed, and that's too early to tell whether it is an obsolescent
1488       --  unit doing the with'ing. In Sem_Ch10.Analyze_Compilation_Unit we make
1489       --  sure that we have a later call when the scope is available. This test
1490       --  also eliminates all messages for use clauses, which is fine (we do
1491       --  not want messages for use clauses, since they are always redundant
1492       --  with respect to the associated with clause).
1493
1494       if S = Standard_Standard then
1495          return;
1496       end if;
1497
1498       --  Do not output message if we are in scope of an obsolescent package
1499       --  or subprogram.
1500
1501       loop
1502          if Is_Obsolescent (S) then
1503             return;
1504          end if;
1505
1506          S := Scope (S);
1507          exit when S = Standard_Standard;
1508       end loop;
1509
1510       --  Here we will output the message
1511
1512       Error_Msg_Sloc := Sloc (E);
1513
1514       --  Case of with clause
1515
1516       if Nkind (P) = N_With_Clause then
1517          if Ekind (E) = E_Package then
1518             Error_Msg_NE
1519               ("?with of obsolescent package& declared#", N, E);
1520          elsif Ekind (E) = E_Procedure then
1521             Error_Msg_NE
1522               ("?with of obsolescent procedure& declared#", N, E);
1523          else
1524             Error_Msg_NE
1525               ("?with of obsolescent function& declared#", N, E);
1526          end if;
1527
1528       --  If we do not have a with clause, then ignore any reference to an
1529       --  obsolescent package name. We only want to give the one warning of
1530       --  withing the package, not one each time it is used to qualify.
1531
1532       elsif Ekind (E) = E_Package then
1533          return;
1534
1535       --  Procedure call statement
1536
1537       elsif Nkind (P) = N_Procedure_Call_Statement then
1538          Error_Msg_NE
1539            ("?call to obsolescent procedure& declared#", N, E);
1540
1541       --  Function call
1542
1543       elsif Nkind (P) = N_Function_Call then
1544          Error_Msg_NE
1545            ("?call to obsolescent function& declared#", N, E);
1546
1547       --  Reference to obsolescent type
1548
1549       elsif Is_Type (E) then
1550          Error_Msg_NE
1551            ("?reference to obsolescent type& declared#", N, E);
1552
1553       --  Reference to obsolescent component
1554
1555       elsif Ekind (E) = E_Component
1556         or else Ekind (E) = E_Discriminant
1557       then
1558          Error_Msg_NE
1559            ("?reference to obsolescent component& declared#", N, E);
1560
1561       --  Reference to obsolescent variable
1562
1563       elsif Ekind (E) = E_Variable then
1564          Error_Msg_NE
1565            ("?reference to obsolescent variable& declared#", N, E);
1566
1567       --  Reference to obsolescent constant
1568
1569       elsif Ekind (E) = E_Constant
1570         or else Ekind (E) in Named_Kind
1571       then
1572          Error_Msg_NE
1573            ("?reference to obsolescent constant& declared#", N, E);
1574
1575       --  Reference to obsolescent enumeration literal
1576
1577       elsif Ekind (E) = E_Enumeration_Literal then
1578          Error_Msg_NE
1579            ("?reference to obsolescent enumeration literal& declared#", N, E);
1580
1581       --  Generic message for any other case we missed
1582
1583       else
1584          Error_Msg_NE
1585            ("?reference to obsolescent entity& declared#", N, E);
1586       end if;
1587
1588       --  Output additional warning if present
1589
1590       declare
1591          W : constant Node_Id := Obsolescent_Warning (E);
1592
1593       begin
1594          if Present (W) then
1595
1596             --  This is a warning continuation to start on a new line
1597             Name_Buffer (1) := '\';
1598             Name_Buffer (2) := '\';
1599             Name_Buffer (3) := '?';
1600             Name_Len := 3;
1601
1602             --  Add characters to message, and output message. Note that
1603             --  we quote every character of the message since we don't
1604             --  want to process any insertions.
1605
1606             for J in 1 .. String_Length (Strval (W)) loop
1607                Add_Char_To_Name_Buffer (''');
1608                Add_Char_To_Name_Buffer
1609                  (Get_Character (Get_String_Char (Strval (W), J)));
1610             end loop;
1611
1612             Error_Msg_N (Name_Buffer (1 .. Name_Len), N);
1613          end if;
1614       end;
1615    end Output_Obsolescent_Entity_Warnings;
1616
1617    ----------------------------------
1618    -- Output_Unreferenced_Messages --
1619    ----------------------------------
1620
1621    procedure Output_Unreferenced_Messages is
1622       E : Entity_Id;
1623
1624    begin
1625       for J in Unreferenced_Entities.First ..
1626                Unreferenced_Entities.Last
1627       loop
1628          E := Unreferenced_Entities.Table (J);
1629
1630          if not Referenced (E) and then not Warnings_Off (E) then
1631             case Ekind (E) is
1632                when E_Variable =>
1633
1634                   --  Case of variable that is assigned but not read. We
1635                   --  suppress the message if the variable is volatile, has an
1636                   --  address clause, or is imported.
1637
1638                   if Referenced_As_LHS (E)
1639                     and then No (Address_Clause (E))
1640                     and then not Is_Volatile (E)
1641                   then
1642                      if Warn_On_Modified_Unread
1643                        and then not Is_Imported (E)
1644
1645                         --  Suppress message for aliased or renamed variables,
1646                         --  since there may be other entities that read the
1647                         --  same memory location.
1648
1649                        and then not Is_Aliased (E)
1650                        and then No (Renamed_Object (E))
1651
1652                      then
1653                         Error_Msg_N
1654                           ("variable & is assigned but never read?", E);
1655                         Set_Last_Assignment (E, Empty);
1656                      end if;
1657
1658                   --  Normal case of neither assigned nor read
1659
1660                   else
1661                      --  We suppress the message for limited controlled types,
1662                      --  to catch the common design pattern (known as RAII, or
1663                      --  Resource Acquisition Is Initialization) which uses
1664                      --  such types solely for their initialization and
1665                      --  finalization semantics.
1666
1667                      if Is_Controlled (Etype (E))
1668                        and then Is_Limited_Type (Etype (E))
1669                      then
1670                         null;
1671
1672                      --  Normal case where we want to give message
1673
1674                      else
1675                         --  Distinguish renamed case in message
1676
1677                         if Present (Renamed_Object (E))
1678                           and then Comes_From_Source (Renamed_Object (E))
1679                         then
1680                            Error_Msg_N
1681                              ("renamed variable & is not referenced?", E);
1682                         else
1683                            Error_Msg_N
1684                              ("variable & is not referenced?", E);
1685                         end if;
1686                      end if;
1687                   end if;
1688
1689                when E_Constant =>
1690                   if Present (Renamed_Object (E))
1691                     and then Comes_From_Source (Renamed_Object (E))
1692                   then
1693                      Error_Msg_N ("renamed constant & is not referenced?", E);
1694                   else
1695                      Error_Msg_N ("constant & is not referenced?", E);
1696                   end if;
1697
1698                when E_In_Parameter     |
1699                     E_Out_Parameter    |
1700                     E_In_Out_Parameter =>
1701
1702                   --  Do not emit message for formals of a renaming, because
1703                   --  they are never referenced explicitly.
1704
1705                   if Nkind (Original_Node (Unit_Declaration_Node (Scope (E))))
1706                     /= N_Subprogram_Renaming_Declaration
1707                   then
1708                      Error_Msg_N ("formal parameter & is not referenced?", E);
1709                   end if;
1710
1711                when E_Named_Integer    |
1712                     E_Named_Real       =>
1713                   Error_Msg_N ("named number & is not referenced?", E);
1714
1715                when E_Enumeration_Literal =>
1716                   Error_Msg_N ("literal & is not referenced?", E);
1717
1718                when E_Function         =>
1719                   Error_Msg_N ("function & is not referenced?", E);
1720
1721                when E_Procedure         =>
1722                   Error_Msg_N ("procedure & is not referenced?", E);
1723
1724                when E_Generic_Procedure =>
1725                   Error_Msg_N
1726                     ("generic procedure & is never instantiated?", E);
1727
1728                when E_Generic_Function  =>
1729                   Error_Msg_N ("generic function & is never instantiated?", E);
1730
1731                when Type_Kind          =>
1732                   Error_Msg_N ("type & is not referenced?", E);
1733
1734                when others =>
1735                   Error_Msg_N ("& is not referenced?", E);
1736             end case;
1737
1738             Set_Warnings_Off (E);
1739          end if;
1740       end loop;
1741    end Output_Unreferenced_Messages;
1742
1743    ------------------------
1744    -- Set_Warning_Switch --
1745    ------------------------
1746
1747    function Set_Warning_Switch (C : Character) return Boolean is
1748    begin
1749       case C is
1750          when 'a' =>
1751             Check_Unreferenced                  := True;
1752             Check_Unreferenced_Formals          := True;
1753             Check_Withs                         := True;
1754             Constant_Condition_Warnings         := True;
1755             Implementation_Unit_Warnings        := True;
1756             Ineffective_Inline_Warnings         := True;
1757             Warn_On_Ada_2005_Compatibility      := True;
1758             Warn_On_Assumed_Low_Bound           := True;
1759             Warn_On_Bad_Fixed_Value             := True;
1760             Warn_On_Constant                    := True;
1761             Warn_On_Export_Import               := True;
1762             Warn_On_Modified_Unread             := True;
1763             Warn_On_No_Value_Assigned           := True;
1764             Warn_On_Obsolescent_Feature         := True;
1765             Warn_On_Questionable_Missing_Parens := True;
1766             Warn_On_Redundant_Constructs        := True;
1767             Warn_On_Unchecked_Conversion        := True;
1768             Warn_On_Unrecognized_Pragma         := True;
1769
1770          when 'A' =>
1771             Check_Unreferenced                  := False;
1772             Check_Unreferenced_Formals          := False;
1773             Check_Withs                         := False;
1774             Constant_Condition_Warnings         := False;
1775             Elab_Warnings                       := False;
1776             Implementation_Unit_Warnings        := False;
1777             Ineffective_Inline_Warnings         := False;
1778             Warn_On_Ada_2005_Compatibility      := False;
1779             Warn_On_Bad_Fixed_Value             := False;
1780             Warn_On_Constant                    := False;
1781             Warn_On_Deleted_Code                := False;
1782             Warn_On_Dereference                 := False;
1783             Warn_On_Export_Import               := False;
1784             Warn_On_Hiding                      := False;
1785             Warn_On_Modified_Unread             := False;
1786             Warn_On_No_Value_Assigned           := False;
1787             Warn_On_Obsolescent_Feature         := False;
1788             Warn_On_Questionable_Missing_Parens := True;
1789             Warn_On_Redundant_Constructs        := False;
1790             Warn_On_Unchecked_Conversion        := False;
1791             Warn_On_Unrecognized_Pragma         := False;
1792
1793          when 'b' =>
1794             Warn_On_Bad_Fixed_Value             := True;
1795
1796          when 'B' =>
1797             Warn_On_Bad_Fixed_Value             := False;
1798
1799          when 'c' =>
1800             Constant_Condition_Warnings         := True;
1801
1802          when 'C' =>
1803             Constant_Condition_Warnings         := False;
1804
1805          when 'd' =>
1806             Warn_On_Dereference                 := True;
1807
1808          when 'D' =>
1809             Warn_On_Dereference                 := False;
1810
1811          when 'e' =>
1812             Warning_Mode                        := Treat_As_Error;
1813
1814          when 'f' =>
1815             Check_Unreferenced_Formals          := True;
1816
1817          when 'F' =>
1818             Check_Unreferenced_Formals          := False;
1819
1820          when 'g' =>
1821             Warn_On_Unrecognized_Pragma         := True;
1822
1823          when 'G' =>
1824             Warn_On_Unrecognized_Pragma         := False;
1825
1826          when 'h' =>
1827             Warn_On_Hiding                      := True;
1828
1829          when 'H' =>
1830             Warn_On_Hiding                      := False;
1831
1832          when 'i' =>
1833             Implementation_Unit_Warnings        := True;
1834
1835          when 'I' =>
1836             Implementation_Unit_Warnings        := False;
1837
1838          when 'j' =>
1839             Warn_On_Obsolescent_Feature         := True;
1840
1841          when 'J' =>
1842             Warn_On_Obsolescent_Feature         := False;
1843
1844          when 'k' =>
1845             Warn_On_Constant                    := True;
1846
1847          when 'K' =>
1848             Warn_On_Constant                    := False;
1849
1850          when 'l' =>
1851             Elab_Warnings                       := True;
1852
1853          when 'L' =>
1854             Elab_Warnings                       := False;
1855
1856          when 'm' =>
1857             Warn_On_Modified_Unread             := True;
1858
1859          when 'M' =>
1860             Warn_On_Modified_Unread             := False;
1861
1862          when 'n' =>
1863             Warning_Mode                        := Normal;
1864
1865          when 'o' =>
1866             Address_Clause_Overlay_Warnings     := True;
1867
1868          when 'O' =>
1869             Address_Clause_Overlay_Warnings     := False;
1870
1871          when 'p' =>
1872             Ineffective_Inline_Warnings         := True;
1873
1874          when 'P' =>
1875             Ineffective_Inline_Warnings         := False;
1876
1877          when 'q' =>
1878             Warn_On_Questionable_Missing_Parens := True;
1879
1880          when 'Q' =>
1881             Warn_On_Questionable_Missing_Parens := False;
1882
1883          when 'r' =>
1884             Warn_On_Redundant_Constructs        := True;
1885
1886          when 'R' =>
1887             Warn_On_Redundant_Constructs        := False;
1888
1889          when 's' =>
1890             Warning_Mode                        := Suppress;
1891
1892          when 't' =>
1893             Warn_On_Deleted_Code                := True;
1894
1895          when 'T' =>
1896             Warn_On_Deleted_Code                := False;
1897
1898          when 'u' =>
1899             Check_Unreferenced                  := True;
1900             Check_Withs                         := True;
1901             Check_Unreferenced_Formals          := True;
1902
1903          when 'U' =>
1904             Check_Unreferenced                  := False;
1905             Check_Withs                         := False;
1906             Check_Unreferenced_Formals          := False;
1907
1908          when 'v' =>
1909             Warn_On_No_Value_Assigned           := True;
1910
1911          when 'V' =>
1912             Warn_On_No_Value_Assigned           := False;
1913
1914          when 'w' =>
1915             Warn_On_Assumed_Low_Bound           := True;
1916
1917          when 'W' =>
1918             Warn_On_Assumed_Low_Bound           := False;
1919
1920          when 'x' =>
1921             Warn_On_Export_Import               := True;
1922
1923          when 'X' =>
1924             Warn_On_Export_Import               := False;
1925
1926          when 'y' =>
1927             Warn_On_Ada_2005_Compatibility      := True;
1928
1929          when 'Y' =>
1930             Warn_On_Ada_2005_Compatibility      := False;
1931
1932          when 'z' =>
1933             Warn_On_Unchecked_Conversion        := True;
1934
1935          when 'Z' =>
1936             Warn_On_Unchecked_Conversion        := False;
1937
1938          when others =>
1939             return False;
1940       end case;
1941
1942       return True;
1943    end Set_Warning_Switch;
1944
1945    -----------------------------
1946    -- Warn_On_Known_Condition --
1947    -----------------------------
1948
1949    procedure Warn_On_Known_Condition (C : Node_Id) is
1950       P : Node_Id;
1951
1952       procedure Track (N : Node_Id; Loc : Node_Id);
1953       --  Adds continuation warning(s) pointing to reason (assignment or test)
1954       --  for the operand of the conditional having a known value (or at least
1955       --  enough is known about the value to issue the warning). N is the node
1956       --  which is judged to have a known value. Loc is the warning location.
1957
1958       -----------
1959       -- Track --
1960       -----------
1961
1962       procedure Track (N : Node_Id; Loc : Node_Id) is
1963          Nod : constant Node_Id := Original_Node (N);
1964
1965       begin
1966          if Nkind (Nod) in N_Op_Compare then
1967             Track (Left_Opnd (Nod), Loc);
1968             Track (Right_Opnd (Nod), Loc);
1969
1970          elsif Is_Entity_Name (Nod)
1971            and then Is_Object (Entity (Nod))
1972          then
1973             declare
1974                CV : constant Node_Id := Current_Value (Entity (Nod));
1975
1976             begin
1977                if Present (CV) then
1978                   Error_Msg_Sloc := Sloc (CV);
1979
1980                   if Nkind (CV) not in N_Subexpr then
1981                      Error_Msg_N ("\\?(see test #)", Loc);
1982
1983                   elsif Nkind (Parent (CV)) =
1984                           N_Case_Statement_Alternative
1985                   then
1986                      Error_Msg_N ("\\?(see case alternative #)", Loc);
1987
1988                   else
1989                      Error_Msg_N ("\\?(see assignment #)", Loc);
1990                   end if;
1991                end if;
1992             end;
1993          end if;
1994       end Track;
1995
1996    --  Start of processing for Warn_On_Known_Condition
1997
1998    begin
1999       --   Argument replacement in an inlined body can make conditions static.
2000       --   Do not emit warnings in this case.
2001
2002       if In_Inlined_Body then
2003          return;
2004       end if;
2005
2006       if Constant_Condition_Warnings
2007         and then Nkind (C) = N_Identifier
2008         and then
2009           (Entity (C) = Standard_False or else Entity (C) = Standard_True)
2010         and then Comes_From_Source (Original_Node (C))
2011         and then not In_Instance
2012       then
2013          --  See if this is in a statement or a declaration
2014
2015          P := Parent (C);
2016          loop
2017             --  If tree is not attached, do not issue warning (this is very
2018             --  peculiar, and probably arises from some other error condition)
2019
2020             if No (P) then
2021                return;
2022
2023             --  If we are in a declaration, then no warning, since in practice
2024             --  conditionals in declarations are used for intended tests which
2025             --  may be known at compile time, e.g. things like
2026
2027             --    x : constant Integer := 2 + (Word'Size = 32);
2028
2029             --  And a warning is annoying in such cases
2030
2031             elsif Nkind (P) in N_Declaration
2032                     or else
2033                   Nkind (P) in N_Later_Decl_Item
2034             then
2035                return;
2036
2037             --  Don't warn in assert pragma, since presumably tests in such
2038             --  a context are very definitely intended, and might well be
2039             --  known at compile time. Note that we have to test the original
2040             --  node, since assert pragmas get rewritten at analysis time.
2041
2042             elsif Nkind (Original_Node (P)) = N_Pragma
2043               and then Chars (Original_Node (P)) = Name_Assert
2044             then
2045                return;
2046             end if;
2047
2048             exit when Is_Statement (P);
2049             P := Parent (P);
2050          end loop;
2051
2052          --  Here we issue the warning unless some sub-operand has warnings
2053          --  set off, in which case we suppress the warning for the node. If
2054          --  the original expression is an inequality, it has been expanded
2055          --  into a negation, and the value of the original expression is the
2056          --  negation of the equality. If the expression is an entity that
2057          --  appears within a negation, it is clearer to flag the negation
2058          --  itself, and report on its constant value.
2059
2060          if not Operand_Has_Warnings_Suppressed (C) then
2061             declare
2062                True_Branch : Boolean := Entity (C) = Standard_True;
2063                Cond        : Node_Id := C;
2064
2065             begin
2066                if Present (Parent (C))
2067                  and then Nkind (Parent (C)) = N_Op_Not
2068                then
2069                   True_Branch := not True_Branch;
2070                   Cond        := Parent (C);
2071                end if;
2072
2073                if True_Branch then
2074                   if Is_Entity_Name (Original_Node (C))
2075                     and then Nkind (Cond) /= N_Op_Not
2076                   then
2077                      Error_Msg_NE
2078                        ("object & is always True?", Cond, Original_Node (C));
2079                      Track (Original_Node (C), Cond);
2080
2081                   else
2082                      Error_Msg_N ("condition is always True?", Cond);
2083                      Track (Cond, Cond);
2084                   end if;
2085
2086                else
2087                   Error_Msg_N ("condition is always False?", Cond);
2088                   Track (Cond, Cond);
2089                end if;
2090             end;
2091          end if;
2092       end if;
2093    end Warn_On_Known_Condition;
2094
2095    ------------------------------
2096    -- Warn_On_Suspicious_Index --
2097    ------------------------------
2098
2099    procedure Warn_On_Suspicious_Index (Name : Entity_Id; X : Node_Id) is
2100
2101       Low_Bound : Uint;
2102       --  Set to lower bound for a suspicious type
2103
2104       Ent : Entity_Id;
2105       --  Entity for array reference
2106
2107       Typ : Entity_Id;
2108       --  Array type
2109
2110       function Is_Suspicious_Type (Typ : Entity_Id) return Boolean;
2111       --  Tests to see if Typ is a type for which we may have a suspicious
2112       --  index, namely an unconstrained array type, whose lower bound is
2113       --  either zero or one. If so, True is returned, and Low_Bound is set
2114       --  to this lower bound. If not, False is returned, and Low_Bound is
2115       --  undefined on return.
2116       --
2117       --  For now, we limite this to standard string types, so any other
2118       --  unconstrained types return False. We may change our minds on this
2119       --  later on, but strings seem the most important case.
2120
2121       procedure Test_Suspicious_Index;
2122       --  Test if index is of suspicious type and if so, generate warning
2123
2124       ------------------------
2125       -- Is_Suspicious_Type --
2126       ------------------------
2127
2128       function Is_Suspicious_Type (Typ : Entity_Id) return Boolean is
2129          LB : Node_Id;
2130
2131       begin
2132          if Is_Array_Type (Typ)
2133            and then not Is_Constrained (Typ)
2134            and then Number_Dimensions (Typ) = 1
2135            and then not Warnings_Off (Typ)
2136            and then (Root_Type (Typ) = Standard_String
2137                        or else
2138                      Root_Type (Typ) = Standard_Wide_String
2139                        or else
2140                      Root_Type (Typ) = Standard_Wide_Wide_String)
2141          then
2142             LB := Type_Low_Bound (Etype (First_Index (Typ)));
2143
2144             if Compile_Time_Known_Value (LB) then
2145                Low_Bound := Expr_Value (LB);
2146                return Low_Bound = Uint_0 or else Low_Bound = Uint_1;
2147             end if;
2148          end if;
2149
2150          return False;
2151       end Is_Suspicious_Type;
2152
2153       ---------------------------
2154       -- Test_Suspicious_Index --
2155       ---------------------------
2156
2157       procedure Test_Suspicious_Index is
2158
2159          function Length_Reference (N : Node_Id) return Boolean;
2160          --  Check if node N is of the form Name'Length
2161
2162          procedure Warn1;
2163          --  Generate first warning line
2164
2165          ----------------------
2166          -- Length_Reference --
2167          ----------------------
2168
2169          function Length_Reference (N : Node_Id) return Boolean is
2170             R : constant Node_Id := Original_Node (N);
2171          begin
2172             return
2173               Nkind (R) = N_Attribute_Reference
2174                and then Attribute_Name (R) = Name_Length
2175                and then Is_Entity_Name (Prefix (R))
2176                and then Entity (Prefix (R)) = Ent;
2177          end Length_Reference;
2178
2179          -----------
2180          -- Warn1 --
2181          -----------
2182
2183          procedure Warn1 is
2184          begin
2185             Error_Msg_Uint_1 := Low_Bound;
2186             Error_Msg_FE ("?index for& may assume lower bound of^", X, Ent);
2187          end Warn1;
2188
2189       --  Start of processing for Test_Suspicious_Index
2190
2191       begin
2192          --  Nothing to do if subscript does not come from source (we don't
2193          --  want to give garbage warnings on compiler expanded code, e.g. the
2194          --  loops generated for slice assignments. Sucb junk warnings would
2195          --  be placed on source constructs with no subscript in sight!)
2196
2197          if not Comes_From_Source (Original_Node (X)) then
2198             return;
2199          end if;
2200
2201          --  Case where subscript is a constant integer
2202
2203          if Nkind (X) = N_Integer_Literal then
2204             Warn1;
2205
2206             --  Case where original form of subscript is an integer literal
2207
2208             if Nkind (Original_Node (X)) = N_Integer_Literal then
2209                if Intval (X) = Low_Bound then
2210                   Error_Msg_FE
2211                     ("\suggested replacement: `&''First`", X, Ent);
2212                else
2213                   Error_Msg_Uint_1 := Intval (X) - Low_Bound;
2214                   Error_Msg_FE
2215                     ("\suggested replacement: `&''First + ^`", X, Ent);
2216
2217                end if;
2218
2219             --  Case where original form of subscript is more complex
2220
2221             else
2222                --  Build string X'First - 1 + expression where the expression
2223                --  is the original subscript. If the expression starts with "1
2224                --  + ", then the "- 1 + 1" is elided.
2225
2226                Error_Msg_String (1 .. 13) := "'First - 1 + ";
2227                Error_Msg_Strlen := 13;
2228
2229                declare
2230                   Sref : Source_Ptr := Sloc (First_Node (Original_Node (X)));
2231                   Tref : constant Source_Buffer_Ptr :=
2232                            Source_Text (Get_Source_File_Index (Sref));
2233                   --  Tref (Sref) is used to scan the subscript
2234
2235                   Pctr : Natural;
2236                   --  Paretheses counter when scanning subscript
2237
2238                begin
2239                   --  Tref (Sref) points to start of subscript
2240
2241                   --  Elide - 1 if subscript starts with 1 +
2242
2243                   if Tref (Sref .. Sref + 2) = "1 +" then
2244                      Error_Msg_Strlen := Error_Msg_Strlen - 6;
2245                      Sref := Sref + 2;
2246
2247                   elsif Tref (Sref .. Sref + 1) = "1+" then
2248                      Error_Msg_Strlen := Error_Msg_Strlen - 6;
2249                      Sref := Sref + 1;
2250                   end if;
2251
2252                   --  Now we will copy the subscript to the string buffer
2253
2254                   Pctr := 0;
2255                   loop
2256                      --  Count parens, exit if terminating right paren. Note
2257                      --  check to ignore paren appearing as character literal.
2258
2259                      if Tref (Sref + 1) = '''
2260                           and then
2261                         Tref (Sref - 1) = '''
2262                      then
2263                         null;
2264                      else
2265                         if Tref (Sref) = '(' then
2266                            Pctr := Pctr + 1;
2267                         elsif Tref (Sref) = ')' then
2268                            exit when Pctr = 0;
2269                            Pctr := Pctr - 1;
2270                         end if;
2271                      end if;
2272
2273                      --  Done if terminating double dot (slice case)
2274
2275                      exit when Pctr = 0
2276                        and then (Tref (Sref .. Sref + 1) = ".."
2277                                   or else
2278                                  Tref (Sref .. Sref + 2) = " ..");
2279
2280                      --  Quit if we have hit EOF character, something wrong
2281
2282                      if Tref (Sref) = EOF then
2283                         return;
2284                      end if;
2285
2286                      --  String literals are too much of a pain to handle
2287
2288                      if Tref (Sref) = '"' or else Tref (Sref) = '%' then
2289                         return;
2290                      end if;
2291
2292                      --  If we have a 'Range reference, then this is a case
2293                      --  where we cannot easily give a replacement. Don't try!
2294
2295                      if Tref (Sref .. Sref + 4) = "range"
2296                        and then Tref (Sref - 1) < 'A'
2297                        and then Tref (Sref + 5) < 'A'
2298                      then
2299                         return;
2300                      end if;
2301
2302                      --  Else store next character
2303
2304                      Error_Msg_Strlen := Error_Msg_Strlen + 1;
2305                      Error_Msg_String (Error_Msg_Strlen) := Tref (Sref);
2306                      Sref := Sref + 1;
2307
2308                      --  If we get more than 40 characters then the expression
2309                      --  is too long to copy, or something has gone wrong. In
2310                      --  either case, just skip the attempt at a suggested fix.
2311
2312                      if Error_Msg_Strlen > 40 then
2313                         return;
2314                      end if;
2315                   end loop;
2316                end;
2317
2318                --  Replacement subscript is now in string buffer
2319
2320                Error_Msg_FE
2321                  ("\suggested replacement: `&~`", Original_Node (X), Ent);
2322             end if;
2323
2324          --  Case where subscript is of the form X'Length
2325
2326          elsif Length_Reference (X) then
2327             Warn1;
2328             Error_Msg_Node_2 := Ent;
2329             Error_Msg_FE
2330               ("\suggest replacement of `&''Length` by `&''Last`",
2331                X, Ent);
2332
2333          --  Case where subscript is of the form X'Length - expression
2334
2335          elsif Nkind (X) = N_Op_Subtract
2336            and then Length_Reference (Left_Opnd (X))
2337          then
2338             Warn1;
2339             Error_Msg_Node_2 := Ent;
2340             Error_Msg_FE
2341               ("\suggest replacement of `&''Length` by `&''Last`",
2342                Left_Opnd (X), Ent);
2343          end if;
2344       end Test_Suspicious_Index;
2345
2346    --  Start of processing for Warn_On_Suspicious_Index
2347
2348    begin
2349       --  Only process if warnings activated
2350
2351       if Warn_On_Assumed_Low_Bound then
2352
2353          --  Test if array is simple entity name
2354
2355          if Is_Entity_Name (Name) then
2356
2357             --  Test if array is parameter of unconstrained string type
2358
2359             Ent := Entity (Name);
2360             Typ := Etype (Ent);
2361
2362             if Is_Formal (Ent)
2363               and then Is_Suspicious_Type (Typ)
2364               and then not Low_Bound_Known (Ent)
2365             then
2366                Test_Suspicious_Index;
2367             end if;
2368          end if;
2369       end if;
2370    end Warn_On_Suspicious_Index;
2371
2372    --------------------------------
2373    -- Warn_On_Useless_Assignment --
2374    --------------------------------
2375
2376    procedure Warn_On_Useless_Assignment
2377      (Ent : Entity_Id;
2378       Loc : Source_Ptr := No_Location)
2379    is
2380       P : Node_Id;
2381       X : Node_Id;
2382
2383       function Check_Ref (N : Node_Id) return Traverse_Result;
2384       --  Used to instantiate Traverse_Func. Returns Abandon if
2385       --  a reference to the entity in question is found.
2386
2387       function Test_No_Refs is new Traverse_Func (Check_Ref);
2388
2389       ---------------
2390       -- Check_Ref --
2391       ---------------
2392
2393       function Check_Ref (N : Node_Id) return Traverse_Result is
2394       begin
2395          --  Check reference to our identifier. We use name equality here
2396          --  because the exception handlers have not yet been analyzed. This
2397          --  is not quite right, but it really does not matter that we fail
2398          --  to output the warning in some obscure cases of name clashes.
2399
2400          if Nkind (N) = N_Identifier
2401            and then Chars (N) = Chars (Ent)
2402          then
2403             return Abandon;
2404          else
2405             return OK;
2406          end if;
2407       end Check_Ref;
2408
2409    --  Start of processing for Warn_On_Useless_Assignment
2410
2411    begin
2412       --  Check if this is a case we want to warn on, a variable with
2413       --  the last assignment field set, with warnings enabled, and
2414       --  which is not imported or exported.
2415
2416       if Ekind (Ent) = E_Variable
2417         and then Present (Last_Assignment (Ent))
2418         and then not Warnings_Off (Ent)
2419         and then not Has_Pragma_Unreferenced (Ent)
2420         and then not Is_Imported (Ent)
2421         and then not Is_Exported (Ent)
2422       then
2423          --  Before we issue the message, check covering exception handlers.
2424          --  Search up tree for enclosing statement sequences and handlers
2425
2426          P := Parent (Last_Assignment (Ent));
2427          while Present (P) loop
2428
2429             --  Something is really wrong if we don't find a handled
2430             --  statement sequence, so just suppress the warning.
2431
2432             if No (P) then
2433                Set_Last_Assignment (Ent, Empty);
2434                return;
2435
2436             --  When we hit a package/subprogram body, issue warning and exit
2437
2438             elsif Nkind (P) = N_Subprogram_Body
2439               or else Nkind (P) = N_Package_Body
2440             then
2441                if Loc = No_Location then
2442                   Error_Msg_NE
2443                     ("?useless assignment to&, value never referenced",
2444                      Last_Assignment (Ent), Ent);
2445                else
2446                   Error_Msg_Sloc := Loc;
2447                   Error_Msg_NE
2448                     ("?useless assignment to&, value overwritten #",
2449                      Last_Assignment (Ent), Ent);
2450                end if;
2451
2452                Set_Last_Assignment (Ent, Empty);
2453                return;
2454
2455             --  Enclosing handled sequence of statements
2456
2457             elsif Nkind (P) = N_Handled_Sequence_Of_Statements then
2458
2459                --  Check exception handlers present
2460
2461                if Present (Exception_Handlers (P)) then
2462
2463                   --  If we are not at the top level, we regard an inner
2464                   --  exception handler as a decisive indicator that we should
2465                   --  not generate the warning, since the variable in question
2466                   --  may be acceessed after an exception in the outer block.
2467
2468                   if Nkind (Parent (P)) /= N_Subprogram_Body
2469                     and then Nkind (Parent (P)) /= N_Package_Body
2470                   then
2471                      Set_Last_Assignment (Ent, Empty);
2472                      return;
2473
2474                      --  Otherwise we are at the outer level. An exception
2475                      --  handler is significant only if it references the
2476                      --  variable in question.
2477
2478                   else
2479                      X := First (Exception_Handlers (P));
2480                      while Present (X) loop
2481                         if Test_No_Refs (X) = Abandon then
2482                            Set_Last_Assignment (Ent, Empty);
2483                            return;
2484                         end if;
2485
2486                         X := Next (X);
2487                      end loop;
2488                   end if;
2489                end if;
2490             end if;
2491
2492             P := Parent (P);
2493          end loop;
2494       end if;
2495    end Warn_On_Useless_Assignment;
2496
2497    ---------------------------------
2498    -- Warn_On_Useless_Assignments --
2499    ---------------------------------
2500
2501    procedure Warn_On_Useless_Assignments (E : Entity_Id) is
2502       Ent : Entity_Id;
2503    begin
2504       if Warn_On_Modified_Unread
2505         and then In_Extended_Main_Source_Unit (E)
2506       then
2507          Ent := First_Entity (E);
2508          while Present (Ent) loop
2509             Warn_On_Useless_Assignment (Ent);
2510             Next_Entity (Ent);
2511          end loop;
2512       end if;
2513    end Warn_On_Useless_Assignments;
2514
2515 end Sem_Warn;