gcc/ada/sem_ch5.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M _ C H 5                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-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 Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Debug;    use Debug;
  30 with Einfo;    use Einfo;
  31 with Errout;   use Errout;
  32 with Expander; use Expander;
  33 with Exp_Util; use Exp_Util;
  34 with Freeze;   use Freeze;
  35 with Lib;      use Lib;
  36 with Lib.Xref; use Lib.Xref;
  37 with Nlists;   use Nlists;
  38 with Nmake;    use Nmake;
  39 with Opt;      use Opt;
  40 with Rtsfind;  use Rtsfind;
  41 with Sem;      use Sem;
  42 with Sem_Case; use Sem_Case;
  43 with Sem_Ch3;  use Sem_Ch3;
  44 with Sem_Ch8;  use Sem_Ch8;
  45 with Sem_Disp; use Sem_Disp;
  46 with Sem_Elab; use Sem_Elab;
  47 with Sem_Eval; use Sem_Eval;
  48 with Sem_Res;  use Sem_Res;
  49 with Sem_Type; use Sem_Type;
  50 with Sem_Util; use Sem_Util;
  51 with Sem_Warn; use Sem_Warn;
  52 with Snames;   use Snames;
  53 with Stand;    use Stand;
  54 with Sinfo;    use Sinfo;
  55 with Targparm; use Targparm;
  56 with Tbuild;   use Tbuild;
  57 with Uintp;    use Uintp;
  58
  59 package body Sem_Ch5 is
  60
  61    Unblocked_Exit_Count : Nat := 0;
  62    --  This variable is used when processing if statements, case statements,
  63    --  and block statements. It counts the number of exit points that are
  64    --  not blocked by unconditional transfer instructions: for IF and CASE,
  65    --  these are the branches of the conditional; for a block, they are the
  66    --  statement sequence of the block, and the statement sequences of any
  67    --  exception handlers that are part of the block. When processing is
  68    --  complete, if this count is zero, it means that control cannot fall
  69    --  through the IF, CASE or block statement. This is used for the
  70    --  generation of warning messages. This variable is recursively saved
  71    --  on entry to processing the construct, and restored on exit.
  72
  73    -----------------------
  74    -- Local Subprograms --
  75    -----------------------
  76
  77    procedure Analyze_Iteration_Scheme (N : Node_Id);
  78
  79    ------------------------
  80    -- Analyze_Assignment --
  81    ------------------------
  82
  83    procedure Analyze_Assignment (N : Node_Id) is
  84       Lhs  : constant Node_Id := Name (N);
  85       Rhs  : constant Node_Id := Expression (N);
  86       T1   : Entity_Id;
  87       T2   : Entity_Id;
  88       Decl : Node_Id;
  89
  90       procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
  91       --  N is the node for the left hand side of an assignment, and it
  92       --  is not a variable. This routine issues an appropriate diagnostic.
  93
  94       procedure Kill_Lhs;
  95       --  This is called to kill current value settings of a simple variable
  96       --  on the left hand side. We call it if we find any error in analyzing
  97       --  the assignment, and at the end of processing before setting any new
  98       --  current values in place.
  99
 100       procedure Set_Assignment_Type
 101         (Opnd      : Node_Id;
 102          Opnd_Type : in out Entity_Id);
 103       --  Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type
 104       --  is the nominal subtype. This procedure is used to deal with cases
 105       --  where the nominal subtype must be replaced by the actual subtype.
 106
 107       -------------------------------
 108       -- Diagnose_Non_Variable_Lhs --
 109       -------------------------------
 110
 111       procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is
 112       begin
 113          --  Not worth posting another error if left hand side already
 114          --  flagged as being illegal in some respect
 115
 116          if Error_Posted (N) then
 117             return;
 118
 119          --  Some special bad cases of entity names
 120
 121          elsif Is_Entity_Name (N) then
 122             if Ekind (Entity (N)) = E_In_Parameter then
 123                Error_Msg_N
 124                  ("assignment to IN mode parameter not allowed", N);
 125
 126             --  Private declarations in a protected object are turned into
 127             --  constants when compiling a protected function.
 128
 129             elsif Present (Scope (Entity (N)))
 130               and then Is_Protected_Type (Scope (Entity (N)))
 131               and then
 132                 (Ekind (Current_Scope) = E_Function
 133                   or else
 134                  Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function)
 135             then
 136                Error_Msg_N
 137                  ("protected function cannot modify protected object", N);
 138
 139             elsif Ekind (Entity (N)) = E_Loop_Parameter then
 140                Error_Msg_N
 141                  ("assignment to loop parameter not allowed", N);
 142
 143             else
 144                Error_Msg_N
 145                  ("left hand side of assignment must be a variable", N);
 146             end if;
 147
 148          --  For indexed components or selected components, test prefix
 149
 150          elsif Nkind (N) = N_Indexed_Component then
 151             Diagnose_Non_Variable_Lhs (Prefix (N));
 152
 153          --  Another special case for assignment to discriminant
 154
 155          elsif Nkind (N) = N_Selected_Component then
 156             if Present (Entity (Selector_Name (N)))
 157               and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
 158             then
 159                Error_Msg_N
 160                  ("assignment to discriminant not allowed", N);
 161             else
 162                Diagnose_Non_Variable_Lhs (Prefix (N));
 163             end if;
 164
 165          else
 166             --  If we fall through, we have no special message to issue!
 167
 168             Error_Msg_N ("left hand side of assignment must be a variable", N);
 169          end if;
 170       end Diagnose_Non_Variable_Lhs;
 171
 172       --------------
 173       -- Kill_LHS --
 174       --------------
 175
 176       procedure Kill_Lhs is
 177       begin
 178          if Is_Entity_Name (Lhs) then
 179             declare
 180                Ent : constant Entity_Id := Entity (Lhs);
 181             begin
 182                if Present (Ent) then
 183                   Kill_Current_Values (Ent);
 184                end if;
 185             end;
 186          end if;
 187       end Kill_Lhs;
 188
 189       -------------------------
 190       -- Set_Assignment_Type --
 191       -------------------------
 192
 193       procedure Set_Assignment_Type
 194         (Opnd      : Node_Id;
 195          Opnd_Type : in out Entity_Id)
 196       is
 197       begin
 198          Require_Entity (Opnd);
 199
 200          --  If the assignment operand is an in-out or out parameter, then we
 201          --  get the actual subtype (needed for the unconstrained case).
 202          --  If the operand is the actual in an entry declaration, then within
 203          --  the accept statement it is replaced with a local renaming, which
 204          --  may also have an actual subtype.
 205
 206          if Is_Entity_Name (Opnd)
 207            and then (Ekind (Entity (Opnd)) = E_Out_Parameter
 208                       or else Ekind (Entity (Opnd)) =
 209                            E_In_Out_Parameter
 210                       or else Ekind (Entity (Opnd)) =
 211                            E_Generic_In_Out_Parameter
 212                       or else
 213                         (Ekind (Entity (Opnd)) = E_Variable
 214                           and then Nkind (Parent (Entity (Opnd))) =
 215                              N_Object_Renaming_Declaration
 216                           and then Nkind (Parent (Parent (Entity (Opnd)))) =
 217                              N_Accept_Statement))
 218          then
 219             Opnd_Type := Get_Actual_Subtype (Opnd);
 220
 221          --  If assignment operand is a component reference, then we get the
 222          --  actual subtype of the component for the unconstrained case.
 223
 224          elsif
 225            (Nkind (Opnd) = N_Selected_Component
 226              or else Nkind (Opnd) = N_Explicit_Dereference)
 227            and then not Is_Unchecked_Union (Opnd_Type)
 228          then
 229             Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
 230
 231             if Present (Decl) then
 232                Insert_Action (N, Decl);
 233                Mark_Rewrite_Insertion (Decl);
 234                Analyze (Decl);
 235                Opnd_Type := Defining_Identifier (Decl);
 236                Set_Etype (Opnd, Opnd_Type);
 237                Freeze_Itype (Opnd_Type, N);
 238
 239             elsif Is_Constrained (Etype (Opnd)) then
 240                Opnd_Type := Etype (Opnd);
 241             end if;
 242
 243          --  For slice, use the constrained subtype created for the slice
 244
 245          elsif Nkind (Opnd) = N_Slice then
 246             Opnd_Type := Etype (Opnd);
 247          end if;
 248       end Set_Assignment_Type;
 249
 250    --  Start of processing for Analyze_Assignment
 251
 252    begin
 253       Analyze (Rhs);
 254       Analyze (Lhs);
 255
 256       --  Start type analysis for assignment
 257
 258       T1 := Etype (Lhs);
 259
 260       --  In the most general case, both Lhs and Rhs can be overloaded, and we
 261       --  must compute the intersection of the possible types on each side.
 262
 263       if Is_Overloaded (Lhs) then
 264          declare
 265             I  : Interp_Index;
 266             It : Interp;
 267
 268          begin
 269             T1 := Any_Type;
 270             Get_First_Interp (Lhs, I, It);
 271
 272             while Present (It.Typ) loop
 273                if Has_Compatible_Type (Rhs, It.Typ) then
 274                   if T1 /= Any_Type then
 275
 276                      --  An explicit dereference is overloaded if the prefix
 277                      --  is. Try to remove the ambiguity on the prefix, the
 278                      --  error will be posted there if the ambiguity is real.
 279
 280                      if Nkind (Lhs) = N_Explicit_Dereference then
 281                         declare
 282                            PI    : Interp_Index;
 283                            PI1   : Interp_Index := 0;
 284                            PIt   : Interp;
 285                            Found : Boolean;
 286
 287                         begin
 288                            Found := False;
 289                            Get_First_Interp (Prefix (Lhs), PI, PIt);
 290
 291                            while Present (PIt.Typ) loop
 292                               if Is_Access_Type (PIt.Typ)
 293                                 and then Has_Compatible_Type
 294                                            (Rhs, Designated_Type (PIt.Typ))
 295                               then
 296                                  if Found then
 297                                     PIt :=
 298                                       Disambiguate (Prefix (Lhs),
 299                                         PI1, PI, Any_Type);
 300
 301                                     if PIt = No_Interp then
 302                                        Error_Msg_N
 303                                          ("ambiguous left-hand side"
 304                                             & " in assignment", Lhs);
 305                                        exit;
 306                                     else
 307                                        Resolve (Prefix (Lhs), PIt.Typ);
 308                                     end if;
 309
 310                                     exit;
 311                                  else
 312                                     Found := True;
 313                                     PI1 := PI;
 314                                  end if;
 315                               end if;
 316
 317                               Get_Next_Interp (PI, PIt);
 318                            end loop;
 319                         end;
 320
 321                      else
 322                         Error_Msg_N
 323                           ("ambiguous left-hand side in assignment", Lhs);
 324                         exit;
 325                      end if;
 326                   else
 327                      T1 := It.Typ;
 328                   end if;
 329                end if;
 330
 331                Get_Next_Interp (I, It);
 332             end loop;
 333          end;
 334
 335          if T1 = Any_Type then
 336             Error_Msg_N
 337               ("no valid types for left-hand side for assignment", Lhs);
 338             Kill_Lhs;
 339             return;
 340          end if;
 341       end if;
 342
 343       Resolve (Lhs, T1);
 344
 345       if not Is_Variable (Lhs) then
 346
 347          --  Ada 2005 (AI-327): Check assignment to the attribute Priority of
 348          --  a protected object.
 349
 350          declare
 351             Ent : Entity_Id;
 352             S   : Entity_Id;
 353
 354          begin
 355             if Ada_Version >= Ada_05 then
 356
 357                --  Handle chains of renamings
 358
 359                Ent := Lhs;
 360                while Nkind (Ent) in N_Has_Entity
 361                  and then Present (Entity (Ent))
 362                  and then Present (Renamed_Object (Entity (Ent)))
 363                loop
 364                   Ent := Renamed_Object (Entity (Ent));
 365                end loop;
 366
 367                if (Nkind (Ent) = N_Attribute_Reference
 368                      and then Attribute_Name (Ent) = Name_Priority)
 369
 370                   --  Renamings of the attribute Priority applied to protected
 371                   --  objects have been previously expanded into calls to the
 372                   --  Get_Ceiling run-time subprogram.
 373
 374                  or else
 375                   (Nkind (Ent) = N_Function_Call
 376                      and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling)
 377                                 or else
 378                                Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling)))
 379                then
 380                   --  The enclosing subprogram cannot be a protected function
 381
 382                   S := Current_Scope;
 383                   while not (Is_Subprogram (S)
 384                                and then Convention (S) = Convention_Protected)
 385                      and then S /= Standard_Standard
 386                   loop
 387                      S := Scope (S);
 388                   end loop;
 389
 390                   if Ekind (S) = E_Function
 391                     and then Convention (S) = Convention_Protected
 392                   then
 393                      Error_Msg_N
 394                        ("protected function cannot modify protected object",
 395                         Lhs);
 396                   end if;
 397
 398                   --  Changes of the ceiling priority of the protected object
 399                   --  are only effective if the Ceiling_Locking policy is in
 400                   --  effect (AARM D.5.2 (5/2)).
 401
 402                   if Locking_Policy /= 'C' then
 403                      Error_Msg_N ("assignment to the attribute PRIORITY has " &
 404                                   "no effect?", Lhs);
 405                      Error_Msg_N ("\since no Locking_Policy has been " &
 406                                   "specified", Lhs);
 407                   end if;
 408
 409                   return;
 410                end if;
 411             end if;
 412          end;
 413
 414          Diagnose_Non_Variable_Lhs (Lhs);
 415          return;
 416
 417       elsif Is_Limited_Type (T1)
 418         and then not Assignment_OK (Lhs)
 419         and then not Assignment_OK (Original_Node (Lhs))
 420       then
 421          Error_Msg_N
 422            ("left hand of assignment must not be limited type", Lhs);
 423          Explain_Limited_Type (T1, Lhs);
 424          return;
 425       end if;
 426
 427       --  Resolution may have updated the subtype, in case the left-hand
 428       --  side is a private protected component. Use the correct subtype
 429       --  to avoid scoping issues in the back-end.
 430
 431       T1 := Etype (Lhs);
 432
 433       --  Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete
 434       --  type. For example:
 435
 436       --    limited with P;
 437       --    package Pkg is
 438       --      type Acc is access P.T;
 439       --    end Pkg;
 440
 441       --    with Pkg; use Acc;
 442       --    procedure Example is
 443       --       A, B : Acc;
 444       --    begin
 445       --       A.all := B.all;  -- ERROR
 446       --    end Example;
 447
 448       if Nkind (Lhs) = N_Explicit_Dereference
 449         and then Ekind (T1) = E_Incomplete_Type
 450       then
 451          Error_Msg_N ("invalid use of incomplete type", Lhs);
 452          Kill_Lhs;
 453          return;
 454       end if;
 455
 456       Set_Assignment_Type (Lhs, T1);
 457
 458       Resolve (Rhs, T1);
 459       Check_Unset_Reference (Rhs);
 460
 461       --  Remaining steps are skipped if Rhs was syntactically in error
 462
 463       if Rhs = Error then
 464          Kill_Lhs;
 465          return;
 466       end if;
 467
 468       T2 := Etype (Rhs);
 469
 470       if not Covers (T1, T2) then
 471          Wrong_Type (Rhs, Etype (Lhs));
 472          Kill_Lhs;
 473          return;
 474       end if;
 475
 476       --  Ada 2005 (AI-326): In case of explicit dereference of incomplete
 477       --  types, use the non-limited view if available
 478
 479       if Nkind (Rhs) = N_Explicit_Dereference
 480         and then Ekind (T2) = E_Incomplete_Type
 481         and then Is_Tagged_Type (T2)
 482         and then Present (Non_Limited_View (T2))
 483       then
 484          T2 := Non_Limited_View (T2);
 485       end if;
 486
 487       Set_Assignment_Type (Rhs, T2);
 488
 489       if Total_Errors_Detected /= 0 then
 490          if No (T1) then
 491             T1 := Any_Type;
 492          end if;
 493
 494          if No (T2) then
 495             T2 := Any_Type;
 496          end if;
 497       end if;
 498
 499       if T1 = Any_Type or else T2 = Any_Type then
 500          Kill_Lhs;
 501          return;
 502       end if;
 503
 504       if (Is_Class_Wide_Type (T2) or else Is_Dynamically_Tagged (Rhs))
 505         and then not Is_Class_Wide_Type (T1)
 506       then
 507          Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
 508
 509       elsif Is_Class_Wide_Type (T1)
 510         and then not Is_Class_Wide_Type (T2)
 511         and then not Is_Tag_Indeterminate (Rhs)
 512         and then not Is_Dynamically_Tagged (Rhs)
 513       then
 514          Error_Msg_N ("dynamically tagged expression required!", Rhs);
 515       end if;
 516
 517       --  Propagate the tag from a class-wide target to the rhs when the rhs
 518       --  is a tag-indeterminate call.
 519
 520       if Is_Tag_Indeterminate (Rhs) then
 521          if Is_Class_Wide_Type (T1) then
 522             Propagate_Tag (Lhs, Rhs);
 523
 524          elsif Nkind (Rhs) = N_Function_Call
 525               and then Is_Entity_Name (Name (Rhs))
 526               and then Is_Abstract_Subprogram (Entity (Name (Rhs)))
 527          then
 528             Error_Msg_N
 529               ("call to abstract function must be dispatching", Name (Rhs));
 530
 531          elsif Nkind (Rhs) = N_Qualified_Expression
 532            and then Nkind (Expression (Rhs)) = N_Function_Call
 533               and then Is_Entity_Name (Name (Expression (Rhs)))
 534               and then
 535                 Is_Abstract_Subprogram (Entity (Name (Expression (Rhs))))
 536          then
 537             Error_Msg_N
 538               ("call to abstract function must be dispatching",
 539                 Name (Expression (Rhs)));
 540          end if;
 541       end if;
 542
 543       --  Ada 2005 (AI-230 and AI-385): When the lhs type is an anonymous
 544       --  access type, apply an implicit conversion of the rhs to that type
 545       --  to force appropriate static and run-time accessibility checks.
 546
 547       if Ada_Version >= Ada_05
 548         and then Ekind (T1) = E_Anonymous_Access_Type
 549       then
 550          Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
 551          Analyze_And_Resolve (Rhs, T1);
 552       end if;
 553
 554       --  Ada 2005 (AI-231)
 555
 556       if Ada_Version >= Ada_05
 557         and then Can_Never_Be_Null (T1)
 558         and then not Assignment_OK (Lhs)
 559       then
 560          if Nkind (Rhs) = N_Null then
 561             Apply_Compile_Time_Constraint_Error
 562               (N   => Rhs,
 563                Msg => "(Ada 2005) NULL not allowed in null-excluding objects?",
 564                Reason => CE_Null_Not_Allowed);
 565             return;
 566
 567          elsif not Can_Never_Be_Null (T2) then
 568             Rewrite (Rhs,
 569               Convert_To (T1, Relocate_Node (Rhs)));
 570             Analyze_And_Resolve (Rhs, T1);
 571          end if;
 572       end if;
 573
 574       if Is_Scalar_Type (T1) then
 575          Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
 576
 577       --  For array types, verify that lengths match. If the right hand side
 578       --  if a function call that has been inlined, the assignment has been
 579       --  rewritten as a block, and the constraint check will be applied to the
 580       --  assignment within the block.
 581
 582       elsif Is_Array_Type (T1)
 583         and then
 584           (Nkind (Rhs) /= N_Type_Conversion
 585             or else Is_Constrained (Etype (Rhs)))
 586         and then
 587           (Nkind (Rhs) /= N_Function_Call
 588             or else Nkind (N) /= N_Block_Statement)
 589       then
 590          --  Assignment verifies that the length of the Lsh and Rhs are equal,
 591          --  but of course the indices do not have to match. If the right-hand
 592          --  side is a type conversion to an unconstrained type, a length check
 593          --  is performed on the expression itself during expansion. In rare
 594          --  cases, the redundant length check is computed on an index type
 595          --  with a different representation, triggering incorrect code in
 596          --  the back end.
 597
 598          Apply_Length_Check (Rhs, Etype (Lhs));
 599
 600       else
 601          --  Discriminant checks are applied in the course of expansion
 602
 603          null;
 604       end if;
 605
 606       --  Note: modifications of the Lhs may only be recorded after
 607       --  checks have been applied.
 608
 609       Note_Possible_Modification (Lhs);
 610
 611       --  ??? a real accessibility check is needed when ???
 612
 613       --  Post warning for redundant assignment or variable to itself
 614
 615       if Warn_On_Redundant_Constructs
 616
 617          --  We only warn for source constructs
 618
 619          and then Comes_From_Source (N)
 620
 621          --  Where the entity is the same on both sides
 622
 623          and then Is_Entity_Name (Lhs)
 624          and then Is_Entity_Name (Original_Node (Rhs))
 625          and then Entity (Lhs) = Entity (Original_Node (Rhs))
 626
 627          --  But exclude the case where the right side was an operation
 628          --  that got rewritten (e.g. JUNK + K, where K was known to be
 629          --  zero). We don't want to warn in such a case, since it is
 630          --  reasonable to write such expressions especially when K is
 631          --  defined symbolically in some other package.
 632
 633         and then Nkind (Original_Node (Rhs)) not in N_Op
 634       then
 635          Error_Msg_NE
 636            ("?useless assignment of & to itself", N, Entity (Lhs));
 637       end if;
 638
 639       --  Check for non-allowed composite assignment
 640
 641       if not Support_Composite_Assign_On_Target
 642         and then (Is_Array_Type (T1) or else Is_Record_Type (T1))
 643         and then (not Has_Size_Clause (T1) or else Esize (T1) > 64)
 644       then
 645          Error_Msg_CRT ("composite assignment", N);
 646       end if;
 647
 648       --  Check elaboration warning for left side if not in elab code
 649
 650       if not In_Subprogram_Or_Concurrent_Unit then
 651          Check_Elab_Assign (Lhs);
 652       end if;
 653
 654       --  Final step. If left side is an entity, then we may be able to
 655       --  reset the current tracked values to new safe values. We only have
 656       --  something to do if the left side is an entity name, and expansion
 657       --  has not modified the node into something other than an assignment,
 658       --  and of course we only capture values if it is safe to do so.
 659
 660       if Is_Entity_Name (Lhs)
 661         and then Nkind (N) = N_Assignment_Statement
 662       then
 663          declare
 664             Ent : constant Entity_Id := Entity (Lhs);
 665
 666          begin
 667             if Safe_To_Capture_Value (N, Ent) then
 668
 669                --  If simple variable on left side, warn if this assignment
 670                --  blots out another one (rendering it useless) and note
 671                --  location of assignment in case no one references value.
 672                --  We only do this for source assignments, otherwise we can
 673                --  generate bogus warnings when an assignment is rewritten as
 674                --  another assignment, and gets tied up with itself.
 675
 676                if Warn_On_Modified_Unread
 677                  and then Ekind (Ent) = E_Variable
 678                  and then Comes_From_Source (N)
 679                  and then In_Extended_Main_Source_Unit (Ent)
 680                then
 681                   Warn_On_Useless_Assignment (Ent, Sloc (N));
 682                   Set_Last_Assignment (Ent, Lhs);
 683                end if;
 684
 685                --  If we are assigning an access type and the left side is an
 686                --  entity, then make sure that the Is_Known_[Non_]Null flags
 687                --  properly reflect the state of the entity after assignment.
 688
 689                if Is_Access_Type (T1) then
 690                   if Known_Non_Null (Rhs) then
 691                      Set_Is_Known_Non_Null (Ent, True);
 692
 693                   elsif Known_Null (Rhs)
 694                     and then not Can_Never_Be_Null (Ent)
 695                   then
 696                      Set_Is_Known_Null (Ent, True);
 697
 698                   else
 699                      Set_Is_Known_Null (Ent, False);
 700
 701                      if not Can_Never_Be_Null (Ent) then
 702                         Set_Is_Known_Non_Null (Ent, False);
 703                      end if;
 704                   end if;
 705
 706                --  For discrete types, we may be able to set the current value
 707                --  if the value is known at compile time.
 708
 709                elsif Is_Discrete_Type (T1)
 710                  and then Compile_Time_Known_Value (Rhs)
 711                then
 712                   Set_Current_Value (Ent, Rhs);
 713                else
 714                   Set_Current_Value (Ent, Empty);
 715                end if;
 716
 717             --  If not safe to capture values, kill them
 718
 719             else
 720                Kill_Lhs;
 721             end if;
 722          end;
 723       end if;
 724    end Analyze_Assignment;
 725
 726    -----------------------------
 727    -- Analyze_Block_Statement --
 728    -----------------------------
 729
 730    procedure Analyze_Block_Statement (N : Node_Id) is
 731       Decls : constant List_Id := Declarations (N);
 732       Id    : constant Node_Id := Identifier (N);
 733       HSS   : constant Node_Id := Handled_Statement_Sequence (N);
 734
 735    begin
 736       --  If no handled statement sequence is present, things are really
 737       --  messed up, and we just return immediately (this is a defence
 738       --  against previous errors).
 739
 740       if No (HSS) then
 741          return;
 742       end if;
 743
 744       --  Normal processing with HSS present
 745
 746       declare
 747          EH  : constant List_Id := Exception_Handlers (HSS);
 748          Ent : Entity_Id        := Empty;
 749          S   : Entity_Id;
 750
 751          Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
 752          --  Recursively save value of this global, will be restored on exit
 753
 754       begin
 755          --  Initialize unblocked exit count for statements of begin block
 756          --  plus one for each excption handler that is present.
 757
 758          Unblocked_Exit_Count := 1;
 759
 760          if Present (EH) then
 761             Unblocked_Exit_Count := Unblocked_Exit_Count + List_Length (EH);
 762          end if;
 763
 764          --  If a label is present analyze it and mark it as referenced
 765
 766          if Present (Id) then
 767             Analyze (Id);
 768             Ent := Entity (Id);
 769
 770             --  An error defense. If we have an identifier, but no entity,
 771             --  then something is wrong. If we have previous errors, then
 772             --  just remove the identifier and continue, otherwise raise
 773             --  an exception.
 774
 775             if No (Ent) then
 776                if Total_Errors_Detected /= 0 then
 777                   Set_Identifier (N, Empty);
 778                else
 779                   raise Program_Error;
 780                end if;
 781
 782             else
 783                Set_Ekind (Ent, E_Block);
 784                Generate_Reference (Ent, N, ' ');
 785                Generate_Definition (Ent);
 786
 787                if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
 788                   Set_Label_Construct (Parent (Ent), N);
 789                end if;
 790             end if;
 791          end if;
 792
 793          --  If no entity set, create a label entity
 794
 795          if No (Ent) then
 796             Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
 797             Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N)));
 798             Set_Parent (Ent, N);
 799          end if;
 800
 801          Set_Etype (Ent, Standard_Void_Type);
 802          Set_Block_Node (Ent, Identifier (N));
 803          New_Scope (Ent);
 804
 805          if Present (Decls) then
 806             Analyze_Declarations (Decls);
 807             Check_Completion;
 808          end if;
 809
 810          Analyze (HSS);
 811          Process_End_Label (HSS, 'e', Ent);
 812
 813          --  If exception handlers are present, then we indicate that
 814          --  enclosing scopes contain a block with handlers. We only
 815          --  need to mark non-generic scopes.
 816
 817          if Present (EH) then
 818             S := Scope (Ent);
 819             loop
 820                Set_Has_Nested_Block_With_Handler (S);
 821                exit when Is_Overloadable (S)
 822                  or else Ekind (S) = E_Package
 823                  or else Is_Generic_Unit (S);
 824                S := Scope (S);
 825             end loop;
 826          end if;
 827
 828          Check_References (Ent);
 829          Warn_On_Useless_Assignments (Ent);
 830          End_Scope;
 831
 832          if Unblocked_Exit_Count = 0 then
 833             Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
 834             Check_Unreachable_Code (N);
 835          else
 836             Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
 837          end if;
 838       end;
 839    end Analyze_Block_Statement;
 840
 841    ----------------------------
 842    -- Analyze_Case_Statement --
 843    ----------------------------
 844
 845    procedure Analyze_Case_Statement (N : Node_Id) is
 846       Exp            : Node_Id;
 847       Exp_Type       : Entity_Id;
 848       Exp_Btype      : Entity_Id;
 849       Last_Choice    : Nat;
 850       Dont_Care      : Boolean;
 851       Others_Present : Boolean;
 852
 853       Statements_Analyzed : Boolean := False;
 854       --  Set True if at least some statement sequences get analyzed.
 855       --  If False on exit, means we had a serious error that prevented
 856       --  full analysis of the case statement, and as a result it is not
 857       --  a good idea to output warning messages about unreachable code.
 858
 859       Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
 860       --  Recursively save value of this global, will be restored on exit
 861
 862       procedure Non_Static_Choice_Error (Choice : Node_Id);
 863       --  Error routine invoked by the generic instantiation below when
 864       --  the case statment has a non static choice.
 865
 866       procedure Process_Statements (Alternative : Node_Id);
 867       --  Analyzes all the statements associated to a case alternative.
 868       --  Needed by the generic instantiation below.
 869
 870       package Case_Choices_Processing is new
 871         Generic_Choices_Processing
 872           (Get_Alternatives          => Alternatives,
 873            Get_Choices               => Discrete_Choices,
 874            Process_Empty_Choice      => No_OP,
 875            Process_Non_Static_Choice => Non_Static_Choice_Error,
 876            Process_Associated_Node   => Process_Statements);
 877       use Case_Choices_Processing;
 878       --  Instantiation of the generic choice processing package
 879
 880       -----------------------------
 881       -- Non_Static_Choice_Error --
 882       -----------------------------
 883
 884       procedure Non_Static_Choice_Error (Choice : Node_Id) is
 885       begin
 886          Flag_Non_Static_Expr
 887            ("choice given in case statement is not static!", Choice);
 888       end Non_Static_Choice_Error;
 889
 890       ------------------------
 891       -- Process_Statements --
 892       ------------------------
 893
 894       procedure Process_Statements (Alternative : Node_Id) is
 895          Choices : constant List_Id := Discrete_Choices (Alternative);
 896          Ent     : Entity_Id;
 897
 898       begin
 899          Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
 900          Statements_Analyzed := True;
 901
 902          --  An interesting optimization. If the case statement expression
 903          --  is a simple entity, then we can set the current value within
 904          --  an alternative if the alternative has one possible value.
 905
 906          --    case N is
 907          --      when 1      => alpha
 908          --      when 2 | 3  => beta
 909          --      when others => gamma
 910
 911          --  Here we know that N is initially 1 within alpha, but for beta
 912          --  and gamma, we do not know anything more about the initial value.
 913
 914          if Is_Entity_Name (Exp) then
 915             Ent := Entity (Exp);
 916
 917             if Ekind (Ent) = E_Variable
 918                  or else
 919                Ekind (Ent) = E_In_Out_Parameter
 920                  or else
 921                Ekind (Ent) = E_Out_Parameter
 922             then
 923                if List_Length (Choices) = 1
 924                  and then Nkind (First (Choices)) in N_Subexpr
 925                  and then Compile_Time_Known_Value (First (Choices))
 926                then
 927                   Set_Current_Value (Entity (Exp), First (Choices));
 928                end if;
 929
 930                Analyze_Statements (Statements (Alternative));
 931
 932                --  After analyzing the case, set the current value to empty
 933                --  since we won't know what it is for the next alternative
 934                --  (unless reset by this same circuit), or after the case.
 935
 936                Set_Current_Value (Entity (Exp), Empty);
 937                return;
 938             end if;
 939          end if;
 940
 941          --  Case where expression is not an entity name of a variable
 942
 943          Analyze_Statements (Statements (Alternative));
 944       end Process_Statements;
 945
 946       --  Table to record choices. Put after subprograms since we make
 947       --  a call to Number_Of_Choices to get the right number of entries.
 948
 949       Case_Table : Choice_Table_Type (1 .. Number_Of_Choices (N));
 950
 951    --  Start of processing for Analyze_Case_Statement
 952
 953    begin
 954       Unblocked_Exit_Count := 0;
 955       Exp := Expression (N);
 956       Analyze (Exp);
 957
 958       --  The expression must be of any discrete type. In rare cases, the
 959       --  expander constructs a case statement whose expression has a private
 960       --  type whose full view is discrete. This can happen when generating
 961       --  a stream operation for a variant type after the type is frozen,
 962       --  when the partial of view of the type of the discriminant is private.
 963       --  In that case, use the full view to analyze case alternatives.
 964
 965       if not Is_Overloaded (Exp)
 966         and then not Comes_From_Source (N)
 967         and then Is_Private_Type (Etype (Exp))
 968         and then Present (Full_View (Etype (Exp)))
 969         and then Is_Discrete_Type (Full_View (Etype (Exp)))
 970       then
 971          Resolve (Exp, Etype (Exp));
 972          Exp_Type := Full_View (Etype (Exp));
 973
 974       else
 975          Analyze_And_Resolve (Exp, Any_Discrete);
 976          Exp_Type := Etype (Exp);
 977       end if;
 978
 979       Check_Unset_Reference (Exp);
 980       Exp_Btype := Base_Type (Exp_Type);
 981
 982       --  The expression must be of a discrete type which must be determinable
 983       --  independently of the context in which the expression occurs, but
 984       --  using the fact that the expression must be of a discrete type.
 985       --  Moreover, the type this expression must not be a character literal
 986       --  (which is always ambiguous) or, for Ada-83, a generic formal type.
 987
 988       --  If error already reported by Resolve, nothing more to do
 989
 990       if Exp_Btype = Any_Discrete
 991         or else Exp_Btype = Any_Type
 992       then
 993          return;
 994
 995       elsif Exp_Btype = Any_Character then
 996          Error_Msg_N
 997            ("character literal as case expression is ambiguous", Exp);
 998          return;
 999
1000       elsif Ada_Version = Ada_83
1001         and then (Is_Generic_Type (Exp_Btype)
1002                     or else Is_Generic_Type (Root_Type (Exp_Btype)))
1003       then
1004          Error_Msg_N
1005            ("(Ada 83) case expression cannot be of a generic type", Exp);
1006          return;
1007       end if;
1008
1009       --  If the case expression is a formal object of mode in out, then
1010       --  treat it as having a nonstatic subtype by forcing use of the base
1011       --  type (which has to get passed to Check_Case_Choices below).  Also
1012       --  use base type when the case expression is parenthesized.
1013
1014       if Paren_Count (Exp) > 0
1015         or else (Is_Entity_Name (Exp)
1016                   and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter)
1017       then
1018          Exp_Type := Exp_Btype;
1019       end if;
1020
1021       --  Call instantiated Analyze_Choices which does the rest of the work
1022
1023       Analyze_Choices
1024         (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
1025
1026       if Exp_Type = Universal_Integer and then not Others_Present then
1027          Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
1028       end if;
1029
1030       --  If all our exits were blocked by unconditional transfers of control,
1031       --  then the entire CASE statement acts as an unconditional transfer of
1032       --  control, so treat it like one, and check unreachable code. Skip this
1033       --  test if we had serious errors preventing any statement analysis.
1034
1035       if Unblocked_Exit_Count = 0 and then Statements_Analyzed then
1036          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1037          Check_Unreachable_Code (N);
1038       else
1039          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1040       end if;
1041
1042       if not Expander_Active
1043         and then Compile_Time_Known_Value (Expression (N))
1044         and then Serious_Errors_Detected = 0
1045       then
1046          declare
1047             Chosen : constant Node_Id := Find_Static_Alternative (N);
1048             Alt    : Node_Id;
1049
1050          begin
1051             Alt := First (Alternatives (N));
1052
1053             while Present (Alt) loop
1054                if Alt /= Chosen then
1055                   Remove_Warning_Messages (Statements (Alt));
1056                end if;
1057
1058                Next (Alt);
1059             end loop;
1060          end;
1061       end if;
1062    end Analyze_Case_Statement;
1063
1064    ----------------------------
1065    -- Analyze_Exit_Statement --
1066    ----------------------------
1067
1068    --  If the exit includes a name, it must be the name of a currently open
1069    --  loop. Otherwise there must be an innermost open loop on the stack,
1070    --  to which the statement implicitly refers.
1071
1072    procedure Analyze_Exit_Statement (N : Node_Id) is
1073       Target   : constant Node_Id := Name (N);
1074       Cond     : constant Node_Id := Condition (N);
1075       Scope_Id : Entity_Id;
1076       U_Name   : Entity_Id;
1077       Kind     : Entity_Kind;
1078
1079    begin
1080       if No (Cond) then
1081          Check_Unreachable_Code (N);
1082       end if;
1083
1084       if Present (Target) then
1085          Analyze (Target);
1086          U_Name := Entity (Target);
1087
1088          if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
1089             Error_Msg_N ("invalid loop name in exit statement", N);
1090             return;
1091          else
1092             Set_Has_Exit (U_Name);
1093          end if;
1094
1095       else
1096          U_Name := Empty;
1097       end if;
1098
1099       for J in reverse 0 .. Scope_Stack.Last loop
1100          Scope_Id := Scope_Stack.Table (J).Entity;
1101          Kind := Ekind (Scope_Id);
1102
1103          if Kind = E_Loop
1104            and then (No (Target) or else Scope_Id = U_Name) then
1105             Set_Has_Exit (Scope_Id);
1106             exit;
1107
1108          elsif Kind = E_Block
1109            or else Kind = E_Loop
1110            or else Kind = E_Return_Statement
1111          then
1112             null;
1113
1114          else
1115             Error_Msg_N
1116               ("cannot exit from program unit or accept statement", N);
1117             exit;
1118          end if;
1119       end loop;
1120
1121       --  Verify that if present the condition is a Boolean expression
1122
1123       if Present (Cond) then
1124          Analyze_And_Resolve (Cond, Any_Boolean);
1125          Check_Unset_Reference (Cond);
1126       end if;
1127    end Analyze_Exit_Statement;
1128
1129    ----------------------------
1130    -- Analyze_Goto_Statement --
1131    ----------------------------
1132
1133    procedure Analyze_Goto_Statement (N : Node_Id) is
1134       Label       : constant Node_Id := Name (N);
1135       Scope_Id    : Entity_Id;
1136       Label_Scope : Entity_Id;
1137       Label_Ent   : Entity_Id;
1138
1139    begin
1140       Check_Unreachable_Code (N);
1141
1142       Analyze (Label);
1143       Label_Ent := Entity (Label);
1144
1145       --  Ignore previous error
1146
1147       if Label_Ent = Any_Id then
1148          return;
1149
1150       --  We just have a label as the target of a goto
1151
1152       elsif Ekind (Label_Ent) /= E_Label then
1153          Error_Msg_N ("target of goto statement must be a label", Label);
1154          return;
1155
1156       --  Check that the target of the goto is reachable according to Ada
1157       --  scoping rules. Note: the special gotos we generate for optimizing
1158       --  local handling of exceptions would violate these rules, but we mark
1159       --  such gotos as analyzed when built, so this code is never entered.
1160
1161       elsif not Reachable (Label_Ent) then
1162          Error_Msg_N ("target of goto statement is not reachable", Label);
1163          return;
1164       end if;
1165
1166       --  Here if goto passes initial validity checks
1167
1168       Label_Scope := Enclosing_Scope (Label_Ent);
1169
1170       for J in reverse 0 .. Scope_Stack.Last loop
1171          Scope_Id := Scope_Stack.Table (J).Entity;
1172
1173          if Label_Scope = Scope_Id
1174            or else (Ekind (Scope_Id) /= E_Block
1175                      and then Ekind (Scope_Id) /= E_Loop
1176                      and then Ekind (Scope_Id) /= E_Return_Statement)
1177          then
1178             if Scope_Id /= Label_Scope then
1179                Error_Msg_N
1180                  ("cannot exit from program unit or accept statement", N);
1181             end if;
1182
1183             return;
1184          end if;
1185       end loop;
1186
1187       raise Program_Error;
1188    end Analyze_Goto_Statement;
1189
1190    --------------------------
1191    -- Analyze_If_Statement --
1192    --------------------------
1193
1194    --  A special complication arises in the analysis of if statements
1195
1196    --  The expander has circuitry to completely delete code that it
1197    --  can tell will not be executed (as a result of compile time known
1198    --  conditions). In the analyzer, we ensure that code that will be
1199    --  deleted in this manner is analyzed but not expanded. This is
1200    --  obviously more efficient, but more significantly, difficulties
1201    --  arise if code is expanded and then eliminated (e.g. exception
1202    --  table entries disappear). Similarly, itypes generated in deleted
1203    --  code must be frozen from start, because the nodes on which they
1204    --  depend will not be available at the freeze point.
1205
1206    procedure Analyze_If_Statement (N : Node_Id) is
1207       E : Node_Id;
1208
1209       Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
1210       --  Recursively save value of this global, will be restored on exit
1211
1212       Save_In_Deleted_Code : Boolean;
1213
1214       Del : Boolean := False;
1215       --  This flag gets set True if a True condition has been found,
1216       --  which means that remaining ELSE/ELSIF parts are deleted.
1217
1218       procedure Analyze_Cond_Then (Cnode : Node_Id);
1219       --  This is applied to either the N_If_Statement node itself or
1220       --  to an N_Elsif_Part node. It deals with analyzing the condition
1221       --  and the THEN statements associated with it.
1222
1223       -----------------------
1224       -- Analyze_Cond_Then --
1225       -----------------------
1226
1227       procedure Analyze_Cond_Then (Cnode : Node_Id) is
1228          Cond : constant Node_Id := Condition (Cnode);
1229          Tstm : constant List_Id := Then_Statements (Cnode);
1230
1231       begin
1232          Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
1233          Analyze_And_Resolve (Cond, Any_Boolean);
1234          Check_Unset_Reference (Cond);
1235          Set_Current_Value_Condition (Cnode);
1236
1237          --  If already deleting, then just analyze then statements
1238
1239          if Del then
1240             Analyze_Statements (Tstm);
1241
1242          --  Compile time known value, not deleting yet
1243
1244          elsif Compile_Time_Known_Value (Cond) then
1245             Save_In_Deleted_Code := In_Deleted_Code;
1246
1247             --  If condition is True, then analyze the THEN statements
1248             --  and set no expansion for ELSE and ELSIF parts.
1249
1250             if Is_True (Expr_Value (Cond)) then
1251                Analyze_Statements (Tstm);
1252                Del := True;
1253                Expander_Mode_Save_And_Set (False);
1254                In_Deleted_Code := True;
1255
1256             --  If condition is False, analyze THEN with expansion off
1257
1258             else -- Is_False (Expr_Value (Cond))
1259                Expander_Mode_Save_And_Set (False);
1260                In_Deleted_Code := True;
1261                Analyze_Statements (Tstm);
1262                Expander_Mode_Restore;
1263                In_Deleted_Code := Save_In_Deleted_Code;
1264             end if;
1265
1266          --  Not known at compile time, not deleting, normal analysis
1267
1268          else
1269             Analyze_Statements (Tstm);
1270          end if;
1271       end Analyze_Cond_Then;
1272
1273    --  Start of Analyze_If_Statement
1274
1275    begin
1276       --  Initialize exit count for else statements. If there is no else
1277       --  part, this count will stay non-zero reflecting the fact that the
1278       --  uncovered else case is an unblocked exit.
1279
1280       Unblocked_Exit_Count := 1;
1281       Analyze_Cond_Then (N);
1282
1283       --  Now to analyze the elsif parts if any are present
1284
1285       if Present (Elsif_Parts (N)) then
1286          E := First (Elsif_Parts (N));
1287          while Present (E) loop
1288             Analyze_Cond_Then (E);
1289             Next (E);
1290          end loop;
1291       end if;
1292
1293       if Present (Else_Statements (N)) then
1294          Analyze_Statements (Else_Statements (N));
1295       end if;
1296
1297       --  If all our exits were blocked by unconditional transfers of control,
1298       --  then the entire IF statement acts as an unconditional transfer of
1299       --  control, so treat it like one, and check unreachable code.
1300
1301       if Unblocked_Exit_Count = 0 then
1302          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1303          Check_Unreachable_Code (N);
1304       else
1305          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1306       end if;
1307
1308       if Del then
1309          Expander_Mode_Restore;
1310          In_Deleted_Code := Save_In_Deleted_Code;
1311       end if;
1312
1313       if not Expander_Active
1314         and then Compile_Time_Known_Value (Condition (N))
1315         and then Serious_Errors_Detected = 0
1316       then
1317          if Is_True (Expr_Value (Condition (N))) then
1318             Remove_Warning_Messages (Else_Statements (N));
1319
1320             if Present (Elsif_Parts (N)) then
1321                E := First (Elsif_Parts (N));
1322
1323                while Present (E) loop
1324                   Remove_Warning_Messages (Then_Statements (E));
1325                   Next (E);
1326                end loop;
1327             end if;
1328
1329          else
1330             Remove_Warning_Messages (Then_Statements (N));
1331          end if;
1332       end if;
1333    end Analyze_If_Statement;
1334
1335    ----------------------------------------
1336    -- Analyze_Implicit_Label_Declaration --
1337    ----------------------------------------
1338
1339    --  An implicit label declaration is generated in the innermost
1340    --  enclosing declarative part. This is done for labels as well as
1341    --  block and loop names.
1342
1343    --  Note: any changes in this routine may need to be reflected in
1344    --  Analyze_Label_Entity.
1345
1346    procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
1347       Id : constant Node_Id := Defining_Identifier (N);
1348    begin
1349       Enter_Name          (Id);
1350       Set_Ekind           (Id, E_Label);
1351       Set_Etype           (Id, Standard_Void_Type);
1352       Set_Enclosing_Scope (Id, Current_Scope);
1353    end Analyze_Implicit_Label_Declaration;
1354
1355    ------------------------------
1356    -- Analyze_Iteration_Scheme --
1357    ------------------------------
1358
1359    procedure Analyze_Iteration_Scheme (N : Node_Id) is
1360
1361       procedure Process_Bounds (R : Node_Id);
1362       --  If the iteration is given by a range, create temporaries and
1363       --  assignment statements block to capture the bounds and perform
1364       --  required finalization actions in case a bound includes a function
1365       --  call that uses the temporary stack. We first pre-analyze a copy of
1366       --  the range in order to determine the expected type, and analyze and
1367       --  resolve the original bounds.
1368
1369       procedure Check_Controlled_Array_Attribute (DS : Node_Id);
1370       --  If the bounds are given by a 'Range reference on a function call
1371       --  that returns a controlled array, introduce an explicit declaration
1372       --  to capture the bounds, so that the function result can be finalized
1373       --  in timely fashion.
1374
1375       --------------------
1376       -- Process_Bounds --
1377       --------------------
1378
1379       procedure Process_Bounds (R : Node_Id) is
1380          Loc          : constant Source_Ptr := Sloc (N);
1381          R_Copy       : constant Node_Id := New_Copy_Tree (R);
1382          Lo           : constant Node_Id := Low_Bound  (R);
1383          Hi           : constant Node_Id := High_Bound (R);
1384          New_Lo_Bound : Node_Id := Empty;
1385          New_Hi_Bound : Node_Id := Empty;
1386          Typ          : Entity_Id;
1387          Save_Analysis : Boolean;
1388
1389          function One_Bound
1390            (Original_Bound : Node_Id;
1391             Analyzed_Bound : Node_Id) return Node_Id;
1392          --  Create one declaration followed by one assignment statement
1393          --  to capture the value of bound. We create a separate assignment
1394          --  in order to force the creation of a block in case the bound
1395          --  contains a call that uses the secondary stack.
1396
1397          ---------------
1398          -- One_Bound --
1399          ---------------
1400
1401          function One_Bound
1402            (Original_Bound : Node_Id;
1403             Analyzed_Bound : Node_Id) return Node_Id
1404          is
1405             Assign : Node_Id;
1406             Id     : Entity_Id;
1407             Decl   : Node_Id;
1408
1409          begin
1410             --  If the bound is a constant or an object, no need for a separate
1411             --  declaration. If the bound is the result of previous expansion
1412             --  it is already analyzed and should not be modified. Note that
1413             --  the Bound will be resolved later, if needed, as part of the
1414             --  call to Make_Index (literal bounds may need to be resolved to
1415             --  type Integer).
1416
1417             if Analyzed (Original_Bound) then
1418                return Original_Bound;
1419
1420             elsif Nkind (Analyzed_Bound) = N_Integer_Literal
1421               or else Is_Entity_Name (Analyzed_Bound)
1422             then
1423                Analyze_And_Resolve (Original_Bound, Typ);
1424                return Original_Bound;
1425
1426             else
1427                Analyze_And_Resolve (Original_Bound, Typ);
1428             end if;
1429
1430             Id :=
1431               Make_Defining_Identifier (Loc,
1432                 Chars => New_Internal_Name ('S'));
1433
1434             Decl :=
1435               Make_Object_Declaration (Loc,
1436                 Defining_Identifier => Id,
1437                 Object_Definition   => New_Occurrence_Of (Typ, Loc));
1438
1439             Insert_Before (Parent (N), Decl);
1440             Analyze (Decl);
1441
1442             Assign :=
1443               Make_Assignment_Statement (Loc,
1444                 Name        => New_Occurrence_Of (Id, Loc),
1445                 Expression  => Relocate_Node (Original_Bound));
1446
1447             Insert_Before (Parent (N), Assign);
1448             Analyze (Assign);
1449
1450             Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
1451
1452             if Nkind (Assign) = N_Assignment_Statement then
1453                return Expression (Assign);
1454             else
1455                return Original_Bound;
1456             end if;
1457          end One_Bound;
1458
1459       --  Start of processing for Process_Bounds
1460
1461       begin
1462          --  Determine expected type of range by analyzing separate copy
1463          --  Do the analysis and resolution of the copy of the bounds with
1464          --  expansion disabled, to prevent the generation of finalization
1465          --  actions on each bound. This prevents memory leaks when the
1466          --  bounds contain calls to functions returning controlled arrays.
1467
1468          Set_Parent (R_Copy, Parent (R));
1469          Save_Analysis := Full_Analysis;
1470          Full_Analysis := False;
1471          Expander_Mode_Save_And_Set (False);
1472
1473          Analyze (R_Copy);
1474
1475          if Is_Overloaded (R_Copy) then
1476
1477             --  Apply preference rules for range of predefined integer types,
1478             --  or diagnose true ambiguity.
1479
1480             declare
1481                I     : Interp_Index;
1482                It    : Interp;
1483                Found : Entity_Id := Empty;
1484
1485             begin
1486                Get_First_Interp (R_Copy, I, It);
1487                while Present (It.Typ) loop
1488                   if Is_Discrete_Type (It.Typ) then
1489                      if No (Found) then
1490                         Found := It.Typ;
1491                      else
1492                         if Scope (Found) = Standard_Standard then
1493                            null;
1494
1495                         elsif Scope (It.Typ) = Standard_Standard then
1496                            Found := It.Typ;
1497
1498                         else
1499                            --  Both of them are user-defined
1500
1501                            Error_Msg_N
1502                              ("ambiguous bounds in range of iteration",
1503                                R_Copy);
1504                            Error_Msg_N ("\possible interpretations:", R_Copy);
1505                            Error_Msg_NE ("\\} ", R_Copy, Found);
1506                            Error_Msg_NE ("\\} ", R_Copy, It.Typ);
1507                            exit;
1508                         end if;
1509                      end if;
1510                   end if;
1511
1512                   Get_Next_Interp (I, It);
1513                end loop;
1514             end;
1515          end if;
1516
1517          Resolve (R_Copy);
1518          Expander_Mode_Restore;
1519          Full_Analysis := Save_Analysis;
1520
1521          Typ := Etype (R_Copy);
1522
1523          --  If the type of the discrete range is Universal_Integer, then
1524          --  the bound's type must be resolved to Integer, and any object
1525          --  used to hold the bound must also have type Integer, unless the
1526          --  literal bounds are constant-folded expressions that carry a user-
1527          --  defined type.
1528
1529          if Typ = Universal_Integer then
1530             if Nkind (Lo) = N_Integer_Literal
1531               and then Present (Etype (Lo))
1532               and then Scope (Etype (Lo)) /= Standard_Standard
1533             then
1534                Typ := Etype (Lo);
1535
1536             elsif Nkind (Hi) = N_Integer_Literal
1537               and then Present (Etype (Hi))
1538               and then Scope (Etype (Hi)) /= Standard_Standard
1539             then
1540                Typ := Etype (Hi);
1541
1542             else
1543                Typ := Standard_Integer;
1544             end if;
1545          end if;
1546
1547          Set_Etype (R, Typ);
1548
1549          New_Lo_Bound := One_Bound (Lo, Low_Bound  (R_Copy));
1550          New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy));
1551
1552          --  Propagate staticness to loop range itself, in case the
1553          --  corresponding subtype is static.
1554
1555          if New_Lo_Bound /= Lo
1556            and then Is_Static_Expression (New_Lo_Bound)
1557          then
1558             Rewrite  (Low_Bound (R), New_Copy (New_Lo_Bound));
1559          end if;
1560
1561          if New_Hi_Bound /= Hi
1562            and then Is_Static_Expression (New_Hi_Bound)
1563          then
1564             Rewrite (High_Bound (R), New_Copy (New_Hi_Bound));
1565          end if;
1566       end Process_Bounds;
1567
1568       --------------------------------------
1569       -- Check_Controlled_Array_Attribute --
1570       --------------------------------------
1571
1572       procedure Check_Controlled_Array_Attribute (DS : Node_Id) is
1573       begin
1574          if Nkind (DS) = N_Attribute_Reference
1575             and then Is_Entity_Name (Prefix (DS))
1576             and then Ekind (Entity (Prefix (DS))) = E_Function
1577             and then Is_Array_Type (Etype (Entity (Prefix (DS))))
1578             and then
1579               Is_Controlled (
1580                 Component_Type (Etype (Entity (Prefix (DS)))))
1581             and then Expander_Active
1582          then
1583             declare
1584                Loc  : constant Source_Ptr := Sloc (N);
1585                Arr  : constant Entity_Id :=
1586                         Etype (Entity (Prefix (DS)));
1587                Indx : constant Entity_Id :=
1588                         Base_Type (Etype (First_Index (Arr)));
1589                Subt : constant Entity_Id :=
1590                         Make_Defining_Identifier
1591                           (Loc, New_Internal_Name ('S'));
1592                Decl : Node_Id;
1593
1594             begin
1595                Decl :=
1596                  Make_Subtype_Declaration (Loc,
1597                    Defining_Identifier => Subt,
1598                    Subtype_Indication  =>
1599                       Make_Subtype_Indication (Loc,
1600                         Subtype_Mark  => New_Reference_To (Indx, Loc),
1601                         Constraint =>
1602                           Make_Range_Constraint (Loc,
1603                             Relocate_Node (DS))));
1604                Insert_Before (Parent (N), Decl);
1605                Analyze (Decl);
1606
1607                Rewrite (DS,
1608                   Make_Attribute_Reference (Loc,
1609                     Prefix => New_Reference_To (Subt, Loc),
1610                     Attribute_Name => Attribute_Name (DS)));
1611                Analyze (DS);
1612             end;
1613          end if;
1614       end Check_Controlled_Array_Attribute;
1615
1616    --  Start of processing for Analyze_Iteration_Scheme
1617
1618    begin
1619       --  For an infinite loop, there is no iteration scheme
1620
1621       if No (N) then
1622          return;
1623
1624       else
1625          declare
1626             Cond : constant Node_Id := Condition (N);
1627
1628          begin
1629             --  For WHILE loop, verify that the condition is a Boolean
1630             --  expression and resolve and check it.
1631
1632             if Present (Cond) then
1633                Analyze_And_Resolve (Cond, Any_Boolean);
1634                Check_Unset_Reference (Cond);
1635                Set_Current_Value_Condition (N);
1636                return;
1637
1638             --  Else we have a FOR loop
1639
1640             else
1641                declare
1642                   LP : constant Node_Id   := Loop_Parameter_Specification (N);
1643                   Id : constant Entity_Id := Defining_Identifier (LP);
1644                   DS : constant Node_Id   := Discrete_Subtype_Definition (LP);
1645
1646                begin
1647                   Enter_Name (Id);
1648
1649                   --  We always consider the loop variable to be referenced,
1650                   --  since the loop may be used just for counting purposes.
1651
1652                   Generate_Reference (Id, N, ' ');
1653
1654                   --  Check for case of loop variable hiding a local
1655                   --  variable (used later on to give a nice warning
1656                   --  if the hidden variable is never assigned).
1657
1658                   declare
1659                      H : constant Entity_Id := Homonym (Id);
1660                   begin
1661                      if Present (H)
1662                        and then Enclosing_Dynamic_Scope (H) =
1663                                 Enclosing_Dynamic_Scope (Id)
1664                        and then Ekind (H) = E_Variable
1665                        and then Is_Discrete_Type (Etype (H))
1666                      then
1667                         Set_Hiding_Loop_Variable (H, Id);
1668                      end if;
1669                   end;
1670
1671                   --  Now analyze the subtype definition. If it is
1672                   --  a range, create temporaries for bounds.
1673
1674                   if Nkind (DS) = N_Range
1675                     and then Expander_Active
1676                   then
1677                      Process_Bounds (DS);
1678                   else
1679                      Analyze (DS);
1680                   end if;
1681
1682                   if DS = Error then
1683                      return;
1684                   end if;
1685
1686                   --  The subtype indication may denote the completion
1687                   --  of an incomplete type declaration.
1688
1689                   if Is_Entity_Name (DS)
1690                     and then Present (Entity (DS))
1691                     and then Is_Type (Entity (DS))
1692                     and then Ekind (Entity (DS)) = E_Incomplete_Type
1693                   then
1694                      Set_Entity (DS, Get_Full_View (Entity (DS)));
1695                      Set_Etype  (DS, Entity (DS));
1696                   end if;
1697
1698                   if not Is_Discrete_Type (Etype (DS)) then
1699                      Wrong_Type (DS, Any_Discrete);
1700                      Set_Etype (DS, Any_Type);
1701                   end if;
1702
1703                   Check_Controlled_Array_Attribute (DS);
1704
1705                   Make_Index (DS, LP);
1706
1707                   Set_Ekind          (Id, E_Loop_Parameter);
1708                   Set_Etype          (Id, Etype (DS));
1709                   Set_Is_Known_Valid (Id, True);
1710
1711                   --  The loop is not a declarative part, so the only entity
1712                   --  declared "within" must be frozen explicitly.
1713
1714                   declare
1715                      Flist : constant List_Id := Freeze_Entity (Id, Sloc (N));
1716                   begin
1717                      if Is_Non_Empty_List (Flist) then
1718                         Insert_Actions (N, Flist);
1719                      end if;
1720                   end;
1721
1722                   --  Check for null or possibly null range and issue warning.
1723                   --  We suppress such messages in generic templates and
1724                   --  instances, because in practice they tend to be dubious
1725                   --  in these cases.
1726
1727                   if Nkind (DS) = N_Range
1728                     and then Comes_From_Source (N)
1729                   then
1730                      declare
1731                         L : constant Node_Id := Low_Bound  (DS);
1732                         H : constant Node_Id := High_Bound (DS);
1733
1734                         Llo : Uint;
1735                         Lhi : Uint;
1736                         LOK : Boolean;
1737                         Hlo : Uint;
1738                         Hhi : Uint;
1739                         HOK : Boolean;
1740
1741                      begin
1742                         Determine_Range (L, LOK, Llo, Lhi);
1743                         Determine_Range (H, HOK, Hlo, Hhi);
1744
1745                         --  If range of loop is null, issue warning
1746
1747                         if (LOK and HOK) and then Llo > Hhi then
1748
1749                            --  Suppress the warning if inside a generic
1750                            --  template or instance, since in practice
1751                            --  they tend to be dubious in these cases since
1752                            --  they can result from intended parametrization.
1753
1754                            if not Inside_A_Generic
1755                               and then not In_Instance
1756                            then
1757                               Error_Msg_N
1758                                 ("?loop range is null, loop will not execute",
1759                                  DS);
1760                            end if;
1761
1762                            --  Since we know the range of the loop is null,
1763                            --  set the appropriate flag to suppress any
1764                            --  warnings that would otherwise be issued in
1765                            --  the body of the loop that will not execute.
1766                            --  We do this even in the generic case, since
1767                            --  if it is dubious to warn on the null loop
1768                            --  itself, it is certainly dubious to warn for
1769                            --  conditions that occur inside it!
1770
1771                            Set_Is_Null_Loop (Parent (N));
1772
1773                         --  The other case for a warning is a reverse loop
1774                         --  where the upper bound is the integer literal
1775                         --  zero or one, and the lower bound can be positive.
1776
1777                         --  For example, we have
1778
1779                         --     for J in reverse N .. 1 loop
1780
1781                         --  In practice, this is very likely to be a case
1782                         --  of reversing the bounds incorrectly in the range.
1783
1784                         elsif Reverse_Present (LP)
1785                           and then Nkind (Original_Node (H)) =
1786                                                           N_Integer_Literal
1787                           and then (Intval (H) = Uint_0
1788                                       or else
1789                                     Intval (H) = Uint_1)
1790                           and then Lhi > Hhi
1791                         then
1792                            Error_Msg_N ("?loop range may be null", DS);
1793                            Error_Msg_N ("\?bounds may be wrong way round", DS);
1794                         end if;
1795                      end;
1796                   end if;
1797                end;
1798             end if;
1799          end;
1800       end if;
1801    end Analyze_Iteration_Scheme;
1802
1803    -------------------
1804    -- Analyze_Label --
1805    -------------------
1806
1807    --  Note: the semantic work required for analyzing labels (setting them as
1808    --  reachable) was done in a prepass through the statements in the block,
1809    --  so that forward gotos would be properly handled. See Analyze_Statements
1810    --  for further details. The only processing required here is to deal with
1811    --  optimizations that depend on an assumption of sequential control flow,
1812    --  since of course the occurrence of a label breaks this assumption.
1813
1814    procedure Analyze_Label (N : Node_Id) is
1815       pragma Warnings (Off, N);
1816    begin
1817       Kill_Current_Values;
1818    end Analyze_Label;
1819
1820    --------------------------
1821    -- Analyze_Label_Entity --
1822    --------------------------
1823
1824    procedure Analyze_Label_Entity (E : Entity_Id) is
1825    begin
1826       Set_Ekind           (E, E_Label);
1827       Set_Etype           (E, Standard_Void_Type);
1828       Set_Enclosing_Scope (E, Current_Scope);
1829       Set_Reachable       (E, True);
1830    end Analyze_Label_Entity;
1831
1832    ----------------------------
1833    -- Analyze_Loop_Statement --
1834    ----------------------------
1835
1836    procedure Analyze_Loop_Statement (N : Node_Id) is
1837       Id   : constant Node_Id := Identifier (N);
1838       Iter : constant Node_Id := Iteration_Scheme (N);
1839       Ent  : Entity_Id;
1840
1841    begin
1842       if Present (Id) then
1843
1844          --  Make name visible, e.g. for use in exit statements. Loop
1845          --  labels are always considered to be referenced.
1846
1847          Analyze (Id);
1848          Ent := Entity (Id);
1849          Generate_Reference  (Ent, N, ' ');
1850          Generate_Definition (Ent);
1851
1852          --  If we found a label, mark its type. If not, ignore it, since it
1853          --  means we have a conflicting declaration, which would already have
1854          --  been diagnosed at declaration time. Set Label_Construct of the
1855          --  implicit label declaration, which is not created by the parser
1856          --  for generic units.
1857
1858          if Ekind (Ent) = E_Label then
1859             Set_Ekind (Ent, E_Loop);
1860
1861             if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
1862                Set_Label_Construct (Parent (Ent), N);
1863             end if;
1864          end if;
1865
1866       --  Case of no identifier present
1867
1868       else
1869          Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L');
1870          Set_Etype (Ent,  Standard_Void_Type);
1871          Set_Parent (Ent, N);
1872       end if;
1873
1874       --  Kill current values on entry to loop, since statements in body
1875       --  of loop may have been executed before the loop is entered.
1876       --  Similarly we kill values after the loop, since we do not know
1877       --  that the body of the loop was executed.
1878
1879       Kill_Current_Values;
1880       New_Scope (Ent);
1881       Analyze_Iteration_Scheme (Iter);
1882       Analyze_Statements (Statements (N));
1883       Process_End_Label (N, 'e', Ent);
1884       End_Scope;
1885       Kill_Current_Values;
1886
1887       --  Check for possible infinite loop which we can diagnose successfully.
1888       --  The case we look for is a while loop which tests a local variable,
1889       --  where there is no obvious direct or indirect update of the variable
1890       --  within the body of the loop.
1891
1892       --  Note: we don't try to give a warning if condition actions are
1893       --  present, since the loop structure can be very complex in this case.
1894
1895       if No (Iter)
1896         or else No (Condition (Iter))
1897         or else Present (Condition_Actions (Iter))
1898         or else Debug_Flag_Dot_W
1899       then
1900          return;
1901       end if;
1902
1903       --  Initial conditions met, see if condition is of right form
1904
1905       declare
1906          Loc  : Node_Id := Empty;
1907          Var  : Entity_Id := Empty;
1908
1909          function Has_Indirection (T : Entity_Id) return Boolean;
1910          --  If the controlling variable is an access type, or is a record type
1911          --  with access components, assume that it is changed indirectly and
1912          --  suppress the warning. As a concession to low-level programming, in
1913          --  particular within Declib, we also suppress warnings on a record
1914          --  type that contains components of type Address or Short_Address.
1915
1916          procedure Find_Var (N : Node_Id);
1917          --  Find whether the condition in a while-loop can be reduced to
1918          --  a test on a single variable. Recurse if condition is negation.
1919
1920          ---------------------
1921          -- Has_Indirection --
1922          ---------------------
1923
1924          function Has_Indirection (T : Entity_Id) return Boolean is
1925             Comp : Entity_Id;
1926             Rec  : Entity_Id;
1927
1928          begin
1929             if Is_Access_Type (T) then
1930                return True;
1931
1932             elsif Is_Private_Type (T)
1933               and then Present (Full_View (T))
1934               and then Is_Access_Type (Full_View (T))
1935             then
1936                return True;
1937
1938             elsif Is_Record_Type (T) then
1939                Rec := T;
1940
1941             elsif Is_Private_Type (T)
1942               and then Present (Full_View (T))
1943               and then Is_Record_Type (Full_View (T))
1944             then
1945                Rec := Full_View (T);
1946             else
1947                return False;
1948             end if;
1949
1950             Comp := First_Component (Rec);
1951             while Present (Comp) loop
1952                if Is_Access_Type (Etype (Comp))
1953                  or else Is_Descendent_Of_Address (Etype (Comp))
1954                then
1955                   return True;
1956                end if;
1957
1958                Next_Component (Comp);
1959             end loop;
1960
1961             return False;
1962          end Has_Indirection;
1963
1964          --------------
1965          -- Find_Var --
1966          --------------
1967
1968          procedure Find_Var (N : Node_Id) is
1969          begin
1970             --  Condition is a direct variable reference
1971
1972             if Is_Entity_Name (N)
1973               and then not Is_Library_Level_Entity (Entity (N))
1974             then
1975                Loc := N;
1976
1977             --  Case of condition is a comparison with compile time known value
1978
1979             elsif Nkind (N) in N_Op_Compare then
1980                if Is_Entity_Name (Left_Opnd (N))
1981                  and then Compile_Time_Known_Value (Right_Opnd (N))
1982                then
1983                   Loc := Left_Opnd (N);
1984
1985                elsif Is_Entity_Name (Right_Opnd (N))
1986                  and then Compile_Time_Known_Value (Left_Opnd (N))
1987                then
1988                   Loc :=  Right_Opnd (N);
1989
1990                else
1991                   return;
1992                end if;
1993
1994             --  If condition is a negation, check whether the operand has the
1995             --  proper form.
1996
1997             elsif Nkind (N) = N_Op_Not then
1998                Find_Var (Right_Opnd (N));
1999
2000             --  Case of condition is function call with one parameter
2001
2002             elsif Nkind (N) = N_Function_Call then
2003                declare
2004                   PA : constant List_Id := Parameter_Associations (N);
2005                begin
2006                   if Present (PA)
2007                     and then List_Length (PA) = 1
2008                     and then Is_Entity_Name (First (PA))
2009                   then
2010                      Loc := First (PA);
2011                   else
2012                      return;
2013                   end if;
2014                end;
2015
2016             else
2017                return;
2018             end if;
2019          end Find_Var;
2020
2021       begin
2022          Find_Var (Condition (Iter));
2023
2024          if Present (Loc) then
2025             Var := Entity (Loc);
2026          end if;
2027
2028          if Present (Var)
2029            and then Ekind (Var) = E_Variable
2030            and then not Is_Library_Level_Entity (Var)
2031            and then Comes_From_Source (Var)
2032          then
2033             if Has_Indirection (Etype (Var)) then
2034
2035                --  Assume that the designated object is modified in some
2036                --  other way, to avoid false positives.
2037
2038                return;
2039
2040             elsif Is_Volatile (Var) then
2041
2042                --  If the variable is marked as volatile, we assume that
2043                --  the condition may be affected by other tasks.
2044
2045                return;
2046
2047             elsif Nkind (Original_Node (First (Statements (N))))
2048                  = N_Delay_Relative_Statement
2049               or else Nkind (Original_Node (First (Statements (N))))
2050                  = N_Delay_Until_Statement
2051             then
2052
2053                --  Assume that this is a multitasking program, and the
2054                --  condition is affected by other threads.
2055
2056                return;
2057
2058             end if;
2059
2060          --  There no identifiable single variable in the condition
2061
2062          else
2063             return;
2064          end if;
2065
2066          --  Search for reference to variable in loop
2067
2068          Ref_Search : declare
2069             function Test_Ref (N : Node_Id) return Traverse_Result;
2070             --  Test for reference to variable in question. Returns Abandon
2071             --  if matching reference found.
2072
2073             function Find_Ref is new Traverse_Func (Test_Ref);
2074             --  Function to traverse body of procedure. Returns Abandon if
2075             --  matching reference found.
2076
2077             --------------
2078             -- Test_Ref --
2079             --------------
2080
2081             function Test_Ref (N : Node_Id) return Traverse_Result is
2082             begin
2083                --  Waste of time to look at iteration scheme
2084
2085                if N = Iter then
2086                   return Skip;
2087
2088                --  Direct reference to variable in question
2089
2090                elsif Is_Entity_Name (N)
2091                  and then Present (Entity (N))
2092                  and then Entity (N) = Var
2093                  and then May_Be_Lvalue (N)
2094                then
2095                   return Abandon;
2096
2097                   --  Reference to variable renaming variable in question
2098
2099                elsif Is_Entity_Name (N)
2100                  and then Present (Entity (N))
2101                  and then Ekind (Entity (N)) = E_Variable
2102                  and then Present (Renamed_Object (Entity (N)))
2103                  and then Is_Entity_Name (Renamed_Object (Entity (N)))
2104                  and then Entity (Renamed_Object (Entity (N))) = Var
2105                  and then May_Be_Lvalue (N)
2106                then
2107                   return Abandon;
2108
2109                --  Calls to subprograms are OK, unless the subprogram is
2110                --  within the scope of the entity in question and could
2111                --  therefore possibly modify it
2112
2113                elsif Nkind (N) = N_Procedure_Call_Statement
2114                  or else Nkind (N) = N_Function_Call
2115                then
2116                   if not Is_Entity_Name (Name (N))
2117                     or else Scope_Within (Entity (Name (N)), Scope (Var))
2118                   then
2119                      return Abandon;
2120                   end if;
2121                end if;
2122
2123                --  All OK, continue scan
2124
2125                return OK;
2126             end Test_Ref;
2127
2128          --  Start of processing for Ref_Search
2129
2130          begin
2131             if Find_Ref (N) = OK then
2132                Error_Msg_NE
2133                  ("variable& is not modified in loop body?", Loc, Var);
2134                Error_Msg_N
2135                  ("\possible infinite loop", Loc);
2136             end if;
2137          end Ref_Search;
2138       end;
2139    end Analyze_Loop_Statement;
2140
2141    ----------------------------
2142    -- Analyze_Null_Statement --
2143    ----------------------------
2144
2145    --  Note: the semantics of the null statement is implemented by a single
2146    --  null statement, too bad everything isn't as simple as this!
2147
2148    procedure Analyze_Null_Statement (N : Node_Id) is
2149       pragma Warnings (Off, N);
2150    begin
2151       null;
2152    end Analyze_Null_Statement;
2153
2154    ------------------------
2155    -- Analyze_Statements --
2156    ------------------------
2157
2158    procedure Analyze_Statements (L : List_Id) is
2159       S   : Node_Id;
2160       Lab : Entity_Id;
2161
2162    begin
2163       --  The labels declared in the statement list are reachable from
2164       --  statements in the list. We do this as a prepass so that any
2165       --  goto statement will be properly flagged if its target is not
2166       --  reachable. This is not required, but is nice behavior!
2167
2168       S := First (L);
2169       while Present (S) loop
2170          if Nkind (S) = N_Label then
2171             Analyze (Identifier (S));
2172             Lab := Entity (Identifier (S));
2173
2174             --  If we found a label mark it as reachable
2175
2176             if Ekind (Lab) = E_Label then
2177                Generate_Definition (Lab);
2178                Set_Reachable (Lab);
2179
2180                if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
2181                   Set_Label_Construct (Parent (Lab), S);
2182                end if;
2183
2184             --  If we failed to find a label, it means the implicit declaration
2185             --  of the label was hidden.  A for-loop parameter can do this to
2186             --  a label with the same name inside the loop, since the implicit
2187             --  label declaration is in the innermost enclosing body or block
2188             --  statement.
2189
2190             else
2191                Error_Msg_Sloc := Sloc (Lab);
2192                Error_Msg_N
2193                  ("implicit label declaration for & is hidden#",
2194                   Identifier (S));
2195             end if;
2196          end if;
2197
2198          Next (S);
2199       end loop;
2200
2201       --  Perform semantic analysis on all statements
2202
2203       Conditional_Statements_Begin;
2204
2205       S := First (L);
2206       while Present (S) loop
2207          Analyze (S);
2208          Next (S);
2209       end loop;
2210
2211       Conditional_Statements_End;
2212
2213       --  Make labels unreachable. Visibility is not sufficient, because
2214       --  labels in one if-branch for example are not reachable from the
2215       --  other branch, even though their declarations are in the enclosing
2216       --  declarative part.
2217
2218       S := First (L);
2219       while Present (S) loop
2220          if Nkind (S) = N_Label then
2221             Set_Reachable (Entity (Identifier (S)), False);
2222          end if;
2223
2224          Next (S);
2225       end loop;
2226    end Analyze_Statements;
2227
2228    ----------------------------
2229    -- Check_Unreachable_Code --
2230    ----------------------------
2231
2232    procedure Check_Unreachable_Code (N : Node_Id) is
2233       Error_Loc : Source_Ptr;
2234       P         : Node_Id;
2235
2236    begin
2237       if Is_List_Member (N)
2238         and then Comes_From_Source (N)
2239       then
2240          declare
2241             Nxt : Node_Id;
2242
2243          begin
2244             Nxt := Original_Node (Next (N));
2245
2246             --  If a label follows us, then we never have dead code, since
2247             --  someone could branch to the label, so we just ignore it.
2248
2249             if Nkind (Nxt) = N_Label then
2250                return;
2251
2252             --  Otherwise see if we have a real statement following us
2253
2254             elsif Present (Nxt)
2255               and then Comes_From_Source (Nxt)
2256               and then Is_Statement (Nxt)
2257             then
2258                --  Special very annoying exception. If we have a return that
2259                --  follows a raise, then we allow it without a warning, since
2260                --  the Ada RM annoyingly requires a useless return here!
2261
2262                if Nkind (Original_Node (N)) /= N_Raise_Statement
2263                  or else Nkind (Nxt) /= N_Return_Statement
2264                then
2265                   --  The rather strange shenanigans with the warning message
2266                   --  here reflects the fact that Kill_Dead_Code is very good
2267                   --  at removing warnings in deleted code, and this is one
2268                   --  warning we would prefer NOT to have removed :-)
2269
2270                   Error_Loc := Sloc (Nxt);
2271
2272                   --  If we have unreachable code, analyze and remove the
2273                   --  unreachable code, since it is useless and we don't
2274                   --  want to generate junk warnings.
2275
2276                   --  We skip this step if we are not in code generation mode.
2277                   --  This is the one case where we remove dead code in the
2278                   --  semantics as opposed to the expander, and we do not want
2279                   --  to remove code if we are not in code generation mode,
2280                   --  since this messes up the ASIS trees.
2281
2282                   --  Note that one might react by moving the whole circuit to
2283                   --  exp_ch5, but then we lose the warning in -gnatc mode.
2284
2285                   if Operating_Mode = Generate_Code then
2286                      loop
2287                         Nxt := Next (N);
2288
2289                         --  Quit deleting when we have nothing more to delete
2290                         --  or if we hit a label (since someone could transfer
2291                         --  control to a label, so we should not delete it).
2292
2293                         exit when No (Nxt) or else Nkind (Nxt) = N_Label;
2294
2295                         --  Statement/declaration is to be deleted
2296
2297                         Analyze (Nxt);
2298                         Remove (Nxt);
2299                         Kill_Dead_Code (Nxt);
2300                      end loop;
2301                   end if;
2302
2303                   --  Now issue the warning
2304
2305                   Error_Msg ("?unreachable code", Error_Loc);
2306                end if;
2307
2308             --  If the unconditional transfer of control instruction is
2309             --  the last statement of a sequence, then see if our parent
2310             --  is one of the constructs for which we count unblocked exits,
2311             --  and if so, adjust the count.
2312
2313             else
2314                P := Parent (N);
2315
2316                --  Statements in THEN part or ELSE part of IF statement
2317
2318                if Nkind (P) = N_If_Statement then
2319                   null;
2320
2321                --  Statements in ELSIF part of an IF statement
2322
2323                elsif Nkind (P) = N_Elsif_Part then
2324                   P := Parent (P);
2325                   pragma Assert (Nkind (P) = N_If_Statement);
2326
2327                --  Statements in CASE statement alternative
2328
2329                elsif Nkind (P) = N_Case_Statement_Alternative then
2330                   P := Parent (P);
2331                   pragma Assert (Nkind (P) = N_Case_Statement);
2332
2333                --  Statements in body of block
2334
2335                elsif Nkind (P) = N_Handled_Sequence_Of_Statements
2336                  and then Nkind (Parent (P)) = N_Block_Statement
2337                then
2338                   null;
2339
2340                --  Statements in exception handler in a block
2341
2342                elsif Nkind (P) = N_Exception_Handler
2343                  and then Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements
2344                  and then Nkind (Parent (Parent (P))) = N_Block_Statement
2345                then
2346                   null;
2347
2348                --  None of these cases, so return
2349
2350                else
2351                   return;
2352                end if;
2353
2354                --  This was one of the cases we are looking for (i.e. the
2355                --  parent construct was IF, CASE or block) so decrement count.
2356
2357                Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
2358             end if;
2359          end;
2360       end if;
2361    end Check_Unreachable_Code;
2362
2363 end Sem_Ch5;