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-2011, 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 3,  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 COPYING3.  If not, go to --
  19 -- http://www.gnu.org/licenses for a complete copy of the license.          --
  20 --                                                                          --
  21 -- GNAT was originally developed  by the GNAT team at  New York University. --
  22 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  23 --                                                                          --
  24 ------------------------------------------------------------------------------
  25
  26 with Aspects;  use Aspects;
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Expander; use Expander;
  32 with Exp_Ch6;  use Exp_Ch6;
  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 Namet;    use Namet;
  38 with Nlists;   use Nlists;
  39 with Nmake;    use Nmake;
  40 with Opt;      use Opt;
  41 with Restrict; use Restrict;
  42 with Rident;   use Rident;
  43 with Rtsfind;  use Rtsfind;
  44 with Sem;      use Sem;
  45 with Sem_Aux;  use Sem_Aux;
  46 with Sem_Case; use Sem_Case;
  47 with Sem_Ch3;  use Sem_Ch3;
  48 with Sem_Ch6;  use Sem_Ch6;
  49 with Sem_Ch8;  use Sem_Ch8;
  50 with Sem_Dim;  use Sem_Dim;
  51 with Sem_Disp; use Sem_Disp;
  52 with Sem_Elab; use Sem_Elab;
  53 with Sem_Eval; use Sem_Eval;
  54 with Sem_Res;  use Sem_Res;
  55 with Sem_Type; use Sem_Type;
  56 with Sem_Util; use Sem_Util;
  57 with Sem_Warn; use Sem_Warn;
  58 with Snames;   use Snames;
  59 with Stand;    use Stand;
  60 with Sinfo;    use Sinfo;
  61 with Targparm; use Targparm;
  62 with Tbuild;   use Tbuild;
  63 with Uintp;    use Uintp;
  64
  65 package body Sem_Ch5 is
  66
  67    Unblocked_Exit_Count : Nat := 0;
  68    --  This variable is used when processing if statements, case statements,
  69    --  and block statements. It counts the number of exit points that are not
  70    --  blocked by unconditional transfer instructions: for IF and CASE, these
  71    --  are the branches of the conditional; for a block, they are the statement
  72    --  sequence of the block, and the statement sequences of any exception
  73    --  handlers that are part of the block. When processing is complete, if
  74    --  this count is zero, it means that control cannot fall through the IF,
  75    --  CASE or block statement. This is used for the generation of warning
  76    --  messages. This variable is recursively saved on entry to processing the
  77    --  construct, and restored on exit.
  78
  79    procedure Pre_Analyze_Range (R_Copy : Node_Id);
  80    --  Determine expected type of range or domain of iteration of Ada 2012
  81    --  loop by analyzing separate copy. Do the analysis and resolution of the
  82    --  copy of the bound(s) with expansion disabled, to prevent the generation
  83    --  of finalization actions. This prevents memory leaks when the bounds
  84    --  contain calls to functions returning controlled arrays or when the
  85    --  domain of iteration is a container.
  86
  87    ------------------------
  88    -- Analyze_Assignment --
  89    ------------------------
  90
  91    procedure Analyze_Assignment (N : Node_Id) is
  92       Lhs  : constant Node_Id := Name (N);
  93       Rhs  : constant Node_Id := Expression (N);
  94       T1   : Entity_Id;
  95       T2   : Entity_Id;
  96       Decl : Node_Id;
  97
  98       procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
  99       --  N is the node for the left hand side of an assignment, and it is not
 100       --  a variable. This routine issues an appropriate diagnostic.
 101
 102       procedure Kill_Lhs;
 103       --  This is called to kill current value settings of a simple variable
 104       --  on the left hand side. We call it if we find any error in analyzing
 105       --  the assignment, and at the end of processing before setting any new
 106       --  current values in place.
 107
 108       procedure Set_Assignment_Type
 109         (Opnd      : Node_Id;
 110          Opnd_Type : in out Entity_Id);
 111       --  Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type is the
 112       --  nominal subtype. This procedure is used to deal with cases where the
 113       --  nominal subtype must be replaced by the actual subtype.
 114
 115       -------------------------------
 116       -- Diagnose_Non_Variable_Lhs --
 117       -------------------------------
 118
 119       procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is
 120       begin
 121          --  Not worth posting another error if left hand side already flagged
 122          --  as being illegal in some respect.
 123
 124          if Error_Posted (N) then
 125             return;
 126
 127          --  Some special bad cases of entity names
 128
 129          elsif Is_Entity_Name (N) then
 130             declare
 131                Ent : constant Entity_Id := Entity (N);
 132
 133             begin
 134                if Ekind (Ent) = E_In_Parameter then
 135                   Error_Msg_N
 136                     ("assignment to IN mode parameter not allowed", N);
 137
 138                --  Renamings of protected private components are turned into
 139                --  constants when compiling a protected function. In the case
 140                --  of single protected types, the private component appears
 141                --  directly.
 142
 143                elsif (Is_Prival (Ent)
 144                         and then
 145                           (Ekind (Current_Scope) = E_Function
 146                              or else Ekind (Enclosing_Dynamic_Scope
 147                                              (Current_Scope)) = E_Function))
 148                    or else
 149                      (Ekind (Ent) = E_Component
 150                         and then Is_Protected_Type (Scope (Ent)))
 151                then
 152                   Error_Msg_N
 153                     ("protected function cannot modify protected object", N);
 154
 155                elsif Ekind (Ent) = E_Loop_Parameter then
 156                   Error_Msg_N
 157                     ("assignment to loop parameter not allowed", N);
 158
 159                else
 160                   Error_Msg_N
 161                     ("left hand side of assignment must be a variable", N);
 162                end if;
 163             end;
 164
 165          --  For indexed components or selected components, test prefix
 166
 167          elsif Nkind (N) = N_Indexed_Component then
 168             Diagnose_Non_Variable_Lhs (Prefix (N));
 169
 170          --  Another special case for assignment to discriminant
 171
 172          elsif Nkind (N) = N_Selected_Component then
 173             if Present (Entity (Selector_Name (N)))
 174               and then Ekind (Entity (Selector_Name (N))) = E_Discriminant
 175             then
 176                Error_Msg_N
 177                  ("assignment to discriminant not allowed", N);
 178             else
 179                Diagnose_Non_Variable_Lhs (Prefix (N));
 180             end if;
 181
 182          else
 183             --  If we fall through, we have no special message to issue!
 184
 185             Error_Msg_N ("left hand side of assignment must be a variable", N);
 186          end if;
 187       end Diagnose_Non_Variable_Lhs;
 188
 189       --------------
 190       -- Kill_LHS --
 191       --------------
 192
 193       procedure Kill_Lhs is
 194       begin
 195          if Is_Entity_Name (Lhs) then
 196             declare
 197                Ent : constant Entity_Id := Entity (Lhs);
 198             begin
 199                if Present (Ent) then
 200                   Kill_Current_Values (Ent);
 201                end if;
 202             end;
 203          end if;
 204       end Kill_Lhs;
 205
 206       -------------------------
 207       -- Set_Assignment_Type --
 208       -------------------------
 209
 210       procedure Set_Assignment_Type
 211         (Opnd      : Node_Id;
 212          Opnd_Type : in out Entity_Id)
 213       is
 214       begin
 215          Require_Entity (Opnd);
 216
 217          --  If the assignment operand is an in-out or out parameter, then we
 218          --  get the actual subtype (needed for the unconstrained case). If the
 219          --  operand is the actual in an entry declaration, then within the
 220          --  accept statement it is replaced with a local renaming, which may
 221          --  also have an actual subtype.
 222
 223          if Is_Entity_Name (Opnd)
 224            and then (Ekind (Entity (Opnd)) = E_Out_Parameter
 225                       or else Ekind (Entity (Opnd)) =
 226                            E_In_Out_Parameter
 227                       or else Ekind (Entity (Opnd)) =
 228                            E_Generic_In_Out_Parameter
 229                       or else
 230                         (Ekind (Entity (Opnd)) = E_Variable
 231                           and then Nkind (Parent (Entity (Opnd))) =
 232                              N_Object_Renaming_Declaration
 233                           and then Nkind (Parent (Parent (Entity (Opnd)))) =
 234                              N_Accept_Statement))
 235          then
 236             Opnd_Type := Get_Actual_Subtype (Opnd);
 237
 238          --  If assignment operand is a component reference, then we get the
 239          --  actual subtype of the component for the unconstrained case.
 240
 241          elsif Nkind_In (Opnd, N_Selected_Component, N_Explicit_Dereference)
 242            and then not Is_Unchecked_Union (Opnd_Type)
 243          then
 244             Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
 245
 246             if Present (Decl) then
 247                Insert_Action (N, Decl);
 248                Mark_Rewrite_Insertion (Decl);
 249                Analyze (Decl);
 250                Opnd_Type := Defining_Identifier (Decl);
 251                Set_Etype (Opnd, Opnd_Type);
 252                Freeze_Itype (Opnd_Type, N);
 253
 254             elsif Is_Constrained (Etype (Opnd)) then
 255                Opnd_Type := Etype (Opnd);
 256             end if;
 257
 258          --  For slice, use the constrained subtype created for the slice
 259
 260          elsif Nkind (Opnd) = N_Slice then
 261             Opnd_Type := Etype (Opnd);
 262          end if;
 263       end Set_Assignment_Type;
 264
 265    --  Start of processing for Analyze_Assignment
 266
 267    begin
 268       Mark_Coextensions (N, Rhs);
 269
 270       Analyze (Rhs);
 271       Analyze (Lhs);
 272
 273       --  Ensure that we never do an assignment on a variable marked as
 274       --  as Safe_To_Reevaluate.
 275
 276       pragma Assert (not Is_Entity_Name (Lhs)
 277         or else Ekind (Entity (Lhs)) /= E_Variable
 278         or else not Is_Safe_To_Reevaluate (Entity (Lhs)));
 279
 280       --  Start type analysis for assignment
 281
 282       T1 := Etype (Lhs);
 283
 284       --  In the most general case, both Lhs and Rhs can be overloaded, and we
 285       --  must compute the intersection of the possible types on each side.
 286
 287       if Is_Overloaded (Lhs) then
 288          declare
 289             I  : Interp_Index;
 290             It : Interp;
 291
 292          begin
 293             T1 := Any_Type;
 294             Get_First_Interp (Lhs, I, It);
 295
 296             while Present (It.Typ) loop
 297                if Has_Compatible_Type (Rhs, It.Typ) then
 298                   if T1 /= Any_Type then
 299
 300                      --  An explicit dereference is overloaded if the prefix
 301                      --  is. Try to remove the ambiguity on the prefix, the
 302                      --  error will be posted there if the ambiguity is real.
 303
 304                      if Nkind (Lhs) = N_Explicit_Dereference then
 305                         declare
 306                            PI    : Interp_Index;
 307                            PI1   : Interp_Index := 0;
 308                            PIt   : Interp;
 309                            Found : Boolean;
 310
 311                         begin
 312                            Found := False;
 313                            Get_First_Interp (Prefix (Lhs), PI, PIt);
 314
 315                            while Present (PIt.Typ) loop
 316                               if Is_Access_Type (PIt.Typ)
 317                                 and then Has_Compatible_Type
 318                                            (Rhs, Designated_Type (PIt.Typ))
 319                               then
 320                                  if Found then
 321                                     PIt :=
 322                                       Disambiguate (Prefix (Lhs),
 323                                         PI1, PI, Any_Type);
 324
 325                                     if PIt = No_Interp then
 326                                        Error_Msg_N
 327                                          ("ambiguous left-hand side"
 328                                             & " in assignment", Lhs);
 329                                        exit;
 330                                     else
 331                                        Resolve (Prefix (Lhs), PIt.Typ);
 332                                     end if;
 333
 334                                     exit;
 335                                  else
 336                                     Found := True;
 337                                     PI1 := PI;
 338                                  end if;
 339                               end if;
 340
 341                               Get_Next_Interp (PI, PIt);
 342                            end loop;
 343                         end;
 344
 345                      else
 346                         Error_Msg_N
 347                           ("ambiguous left-hand side in assignment", Lhs);
 348                         exit;
 349                      end if;
 350                   else
 351                      T1 := It.Typ;
 352                   end if;
 353                end if;
 354
 355                Get_Next_Interp (I, It);
 356             end loop;
 357          end;
 358
 359          if T1 = Any_Type then
 360             Error_Msg_N
 361               ("no valid types for left-hand side for assignment", Lhs);
 362             Kill_Lhs;
 363             return;
 364          end if;
 365       end if;
 366
 367       --  The resulting assignment type is T1, so now we will resolve the left
 368       --  hand side of the assignment using this determined type.
 369
 370       Resolve (Lhs, T1);
 371
 372       --  Cases where Lhs is not a variable
 373
 374       if not Is_Variable (Lhs) then
 375
 376          --  Ada 2005 (AI-327): Check assignment to the attribute Priority of a
 377          --  protected object.
 378
 379          declare
 380             Ent : Entity_Id;
 381             S   : Entity_Id;
 382
 383          begin
 384             if Ada_Version >= Ada_2005 then
 385
 386                --  Handle chains of renamings
 387
 388                Ent := Lhs;
 389                while Nkind (Ent) in N_Has_Entity
 390                  and then Present (Entity (Ent))
 391                  and then Present (Renamed_Object (Entity (Ent)))
 392                loop
 393                   Ent := Renamed_Object (Entity (Ent));
 394                end loop;
 395
 396                if (Nkind (Ent) = N_Attribute_Reference
 397                      and then Attribute_Name (Ent) = Name_Priority)
 398
 399                   --  Renamings of the attribute Priority applied to protected
 400                   --  objects have been previously expanded into calls to the
 401                   --  Get_Ceiling run-time subprogram.
 402
 403                  or else
 404                   (Nkind (Ent) = N_Function_Call
 405                      and then (Entity (Name (Ent)) = RTE (RE_Get_Ceiling)
 406                                 or else
 407                                Entity (Name (Ent)) = RTE (RO_PE_Get_Ceiling)))
 408                then
 409                   --  The enclosing subprogram cannot be a protected function
 410
 411                   S := Current_Scope;
 412                   while not (Is_Subprogram (S)
 413                                and then Convention (S) = Convention_Protected)
 414                      and then S /= Standard_Standard
 415                   loop
 416                      S := Scope (S);
 417                   end loop;
 418
 419                   if Ekind (S) = E_Function
 420                     and then Convention (S) = Convention_Protected
 421                   then
 422                      Error_Msg_N
 423                        ("protected function cannot modify protected object",
 424                         Lhs);
 425                   end if;
 426
 427                   --  Changes of the ceiling priority of the protected object
 428                   --  are only effective if the Ceiling_Locking policy is in
 429                   --  effect (AARM D.5.2 (5/2)).
 430
 431                   if Locking_Policy /= 'C' then
 432                      Error_Msg_N ("assignment to the attribute PRIORITY has " &
 433                                   "no effect?", Lhs);
 434                      Error_Msg_N ("\since no Locking_Policy has been " &
 435                                   "specified", Lhs);
 436                   end if;
 437
 438                   return;
 439                end if;
 440             end if;
 441          end;
 442
 443          Diagnose_Non_Variable_Lhs (Lhs);
 444          return;
 445
 446       --  Error of assigning to limited type. We do however allow this in
 447       --  certain cases where the front end generates the assignments.
 448
 449       elsif Is_Limited_Type (T1)
 450         and then not Assignment_OK (Lhs)
 451         and then not Assignment_OK (Original_Node (Lhs))
 452         and then not Is_Value_Type (T1)
 453       then
 454          --  CPP constructors can only be called in declarations
 455
 456          if Is_CPP_Constructor_Call (Rhs) then
 457             Error_Msg_N ("invalid use of 'C'P'P constructor", Rhs);
 458          else
 459             Error_Msg_N
 460               ("left hand of assignment must not be limited type", Lhs);
 461             Explain_Limited_Type (T1, Lhs);
 462          end if;
 463          return;
 464
 465       --  Enforce RM 3.9.3 (8): the target of an assignment operation cannot be
 466       --  abstract. This is only checked when the assignment Comes_From_Source,
 467       --  because in some cases the expander generates such assignments (such
 468       --  in the _assign operation for an abstract type).
 469
 470       elsif Is_Abstract_Type (T1) and then Comes_From_Source (N) then
 471          Error_Msg_N
 472            ("target of assignment operation must not be abstract", Lhs);
 473       end if;
 474
 475       --  Resolution may have updated the subtype, in case the left-hand side
 476       --  is a private protected component. Use the correct subtype to avoid
 477       --  scoping issues in the back-end.
 478
 479       T1 := Etype (Lhs);
 480
 481       --  Ada 2005 (AI-50217, AI-326): Check wrong dereference of incomplete
 482       --  type. For example:
 483
 484       --    limited with P;
 485       --    package Pkg is
 486       --      type Acc is access P.T;
 487       --    end Pkg;
 488
 489       --    with Pkg; use Acc;
 490       --    procedure Example is
 491       --       A, B : Acc;
 492       --    begin
 493       --       A.all := B.all;  -- ERROR
 494       --    end Example;
 495
 496       if Nkind (Lhs) = N_Explicit_Dereference
 497         and then Ekind (T1) = E_Incomplete_Type
 498       then
 499          Error_Msg_N ("invalid use of incomplete type", Lhs);
 500          Kill_Lhs;
 501          return;
 502       end if;
 503
 504       --  Now we can complete the resolution of the right hand side
 505
 506       Set_Assignment_Type (Lhs, T1);
 507       Resolve (Rhs, T1);
 508
 509       --  This is the point at which we check for an unset reference
 510
 511       Check_Unset_Reference (Rhs);
 512       Check_Unprotected_Access (Lhs, Rhs);
 513
 514       --  Remaining steps are skipped if Rhs was syntactically in error
 515
 516       if Rhs = Error then
 517          Kill_Lhs;
 518          return;
 519       end if;
 520
 521       T2 := Etype (Rhs);
 522
 523       if not Covers (T1, T2) then
 524          Wrong_Type (Rhs, Etype (Lhs));
 525          Kill_Lhs;
 526          return;
 527       end if;
 528
 529       --  Ada 2005 (AI-326): In case of explicit dereference of incomplete
 530       --  types, use the non-limited view if available
 531
 532       if Nkind (Rhs) = N_Explicit_Dereference
 533         and then Ekind (T2) = E_Incomplete_Type
 534         and then Is_Tagged_Type (T2)
 535         and then Present (Non_Limited_View (T2))
 536       then
 537          T2 := Non_Limited_View (T2);
 538       end if;
 539
 540       Set_Assignment_Type (Rhs, T2);
 541
 542       if Total_Errors_Detected /= 0 then
 543          if No (T1) then
 544             T1 := Any_Type;
 545          end if;
 546
 547          if No (T2) then
 548             T2 := Any_Type;
 549          end if;
 550       end if;
 551
 552       if T1 = Any_Type or else T2 = Any_Type then
 553          Kill_Lhs;
 554          return;
 555       end if;
 556
 557       --  If the rhs is class-wide or dynamically tagged, then require the lhs
 558       --  to be class-wide. The case where the rhs is a dynamically tagged call
 559       --  to a dispatching operation with a controlling access result is
 560       --  excluded from this check, since the target has an access type (and
 561       --  no tag propagation occurs in that case).
 562
 563       if (Is_Class_Wide_Type (T2)
 564            or else (Is_Dynamically_Tagged (Rhs)
 565                      and then not Is_Access_Type (T1)))
 566         and then not Is_Class_Wide_Type (T1)
 567       then
 568          Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
 569
 570       elsif Is_Class_Wide_Type (T1)
 571         and then not Is_Class_Wide_Type (T2)
 572         and then not Is_Tag_Indeterminate (Rhs)
 573         and then not Is_Dynamically_Tagged (Rhs)
 574       then
 575          Error_Msg_N ("dynamically tagged expression required!", Rhs);
 576       end if;
 577
 578       --  Propagate the tag from a class-wide target to the rhs when the rhs
 579       --  is a tag-indeterminate call.
 580
 581       if Is_Tag_Indeterminate (Rhs) then
 582          if Is_Class_Wide_Type (T1) then
 583             Propagate_Tag (Lhs, Rhs);
 584
 585          elsif Nkind (Rhs) = N_Function_Call
 586               and then Is_Entity_Name (Name (Rhs))
 587               and then Is_Abstract_Subprogram (Entity (Name (Rhs)))
 588          then
 589             Error_Msg_N
 590               ("call to abstract function must be dispatching", Name (Rhs));
 591
 592          elsif Nkind (Rhs) = N_Qualified_Expression
 593            and then Nkind (Expression (Rhs)) = N_Function_Call
 594               and then Is_Entity_Name (Name (Expression (Rhs)))
 595               and then
 596                 Is_Abstract_Subprogram (Entity (Name (Expression (Rhs))))
 597          then
 598             Error_Msg_N
 599               ("call to abstract function must be dispatching",
 600                 Name (Expression (Rhs)));
 601          end if;
 602       end if;
 603
 604       --  Ada 2005 (AI-385): When the lhs type is an anonymous access type,
 605       --  apply an implicit conversion of the rhs to that type to force
 606       --  appropriate static and run-time accessibility checks. This applies
 607       --  as well to anonymous access-to-subprogram types that are component
 608       --  subtypes or formal parameters.
 609
 610       if Ada_Version >= Ada_2005
 611         and then Is_Access_Type (T1)
 612       then
 613          if Is_Local_Anonymous_Access (T1)
 614            or else Ekind (T2) = E_Anonymous_Access_Subprogram_Type
 615
 616            --  Handle assignment to an Ada 2012 stand-alone object
 617            --  of an anonymous access type.
 618
 619            or else (Ekind (T1) = E_Anonymous_Access_Type
 620                      and then Nkind (Associated_Node_For_Itype (T1)) =
 621                                                        N_Object_Declaration)
 622
 623          then
 624             Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
 625             Analyze_And_Resolve (Rhs, T1);
 626          end if;
 627       end if;
 628
 629       --  Ada 2005 (AI-231): Assignment to not null variable
 630
 631       if Ada_Version >= Ada_2005
 632         and then Can_Never_Be_Null (T1)
 633         and then not Assignment_OK (Lhs)
 634       then
 635          --  Case where we know the right hand side is null
 636
 637          if Known_Null (Rhs) then
 638             Apply_Compile_Time_Constraint_Error
 639               (N   => Rhs,
 640                Msg => "(Ada 2005) null not allowed in null-excluding objects?",
 641                Reason => CE_Null_Not_Allowed);
 642
 643             --  We still mark this as a possible modification, that's necessary
 644             --  to reset Is_True_Constant, and desirable for xref purposes.
 645
 646             Note_Possible_Modification (Lhs, Sure => True);
 647             return;
 648
 649          --  If we know the right hand side is non-null, then we convert to the
 650          --  target type, since we don't need a run time check in that case.
 651
 652          elsif not Can_Never_Be_Null (T2) then
 653             Rewrite (Rhs, Convert_To (T1, Relocate_Node (Rhs)));
 654             Analyze_And_Resolve (Rhs, T1);
 655          end if;
 656       end if;
 657
 658       if Is_Scalar_Type (T1) then
 659          Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
 660
 661       --  For array types, verify that lengths match. If the right hand side
 662       --  is a function call that has been inlined, the assignment has been
 663       --  rewritten as a block, and the constraint check will be applied to the
 664       --  assignment within the block.
 665
 666       elsif Is_Array_Type (T1)
 667         and then
 668           (Nkind (Rhs) /= N_Type_Conversion
 669             or else Is_Constrained (Etype (Rhs)))
 670         and then
 671           (Nkind (Rhs) /= N_Function_Call
 672             or else Nkind (N) /= N_Block_Statement)
 673       then
 674          --  Assignment verifies that the length of the Lsh and Rhs are equal,
 675          --  but of course the indexes do not have to match. If the right-hand
 676          --  side is a type conversion to an unconstrained type, a length check
 677          --  is performed on the expression itself during expansion. In rare
 678          --  cases, the redundant length check is computed on an index type
 679          --  with a different representation, triggering incorrect code in the
 680          --  back end.
 681
 682          Apply_Length_Check (Rhs, Etype (Lhs));
 683
 684       else
 685          --  Discriminant checks are applied in the course of expansion
 686
 687          null;
 688       end if;
 689
 690       --  Note: modifications of the Lhs may only be recorded after
 691       --  checks have been applied.
 692
 693       Note_Possible_Modification (Lhs, Sure => True);
 694       Check_Order_Dependence;
 695
 696       --  ??? a real accessibility check is needed when ???
 697
 698       --  Post warning for redundant assignment or variable to itself
 699
 700       if Warn_On_Redundant_Constructs
 701
 702          --  We only warn for source constructs
 703
 704          and then Comes_From_Source (N)
 705
 706          --  Where the object is the same on both sides
 707
 708          and then Same_Object (Lhs, Original_Node (Rhs))
 709
 710          --  But exclude the case where the right side was an operation that
 711          --  got rewritten (e.g. JUNK + K, where K was known to be zero). We
 712          --  don't want to warn in such a case, since it is reasonable to write
 713          --  such expressions especially when K is defined symbolically in some
 714          --  other package.
 715
 716         and then Nkind (Original_Node (Rhs)) not in N_Op
 717       then
 718          if Nkind (Lhs) in N_Has_Entity then
 719             Error_Msg_NE -- CODEFIX
 720               ("?useless assignment of & to itself!", N, Entity (Lhs));
 721          else
 722             Error_Msg_N -- CODEFIX
 723               ("?useless assignment of object to itself!", N);
 724          end if;
 725       end if;
 726
 727       --  Check for non-allowed composite assignment
 728
 729       if not Support_Composite_Assign_On_Target
 730         and then (Is_Array_Type (T1) or else Is_Record_Type (T1))
 731         and then (not Has_Size_Clause (T1) or else Esize (T1) > 64)
 732       then
 733          Error_Msg_CRT ("composite assignment", N);
 734       end if;
 735
 736       --  Check elaboration warning for left side if not in elab code
 737
 738       if not In_Subprogram_Or_Concurrent_Unit then
 739          Check_Elab_Assign (Lhs);
 740       end if;
 741
 742       --  Set Referenced_As_LHS if appropriate. We only set this flag if the
 743       --  assignment is a source assignment in the extended main source unit.
 744       --  We are not interested in any reference information outside this
 745       --  context, or in compiler generated assignment statements.
 746
 747       if Comes_From_Source (N)
 748         and then In_Extended_Main_Source_Unit (Lhs)
 749       then
 750          Set_Referenced_Modified (Lhs, Out_Param => False);
 751       end if;
 752
 753       --  Final step. If left side is an entity, then we may be able to reset
 754       --  the current tracked values to new safe values. We only have something
 755       --  to do if the left side is an entity name, and expansion has not
 756       --  modified the node into something other than an assignment, and of
 757       --  course we only capture values if it is safe to do so.
 758
 759       if Is_Entity_Name (Lhs)
 760         and then Nkind (N) = N_Assignment_Statement
 761       then
 762          declare
 763             Ent : constant Entity_Id := Entity (Lhs);
 764
 765          begin
 766             if Safe_To_Capture_Value (N, Ent) then
 767
 768                --  If simple variable on left side, warn if this assignment
 769                --  blots out another one (rendering it useless). We only do
 770                --  this for source assignments, otherwise we can generate bogus
 771                --  warnings when an assignment is rewritten as another
 772                --  assignment, and gets tied up with itself.
 773
 774                if Warn_On_Modified_Unread
 775                  and then Is_Assignable (Ent)
 776                  and then Comes_From_Source (N)
 777                  and then In_Extended_Main_Source_Unit (Ent)
 778                then
 779                   Warn_On_Useless_Assignment (Ent, N);
 780                end if;
 781
 782                --  If we are assigning an access type and the left side is an
 783                --  entity, then make sure that the Is_Known_[Non_]Null flags
 784                --  properly reflect the state of the entity after assignment.
 785
 786                if Is_Access_Type (T1) then
 787                   if Known_Non_Null (Rhs) then
 788                      Set_Is_Known_Non_Null (Ent, True);
 789
 790                   elsif Known_Null (Rhs)
 791                     and then not Can_Never_Be_Null (Ent)
 792                   then
 793                      Set_Is_Known_Null (Ent, True);
 794
 795                   else
 796                      Set_Is_Known_Null (Ent, False);
 797
 798                      if not Can_Never_Be_Null (Ent) then
 799                         Set_Is_Known_Non_Null (Ent, False);
 800                      end if;
 801                   end if;
 802
 803                --  For discrete types, we may be able to set the current value
 804                --  if the value is known at compile time.
 805
 806                elsif Is_Discrete_Type (T1)
 807                  and then Compile_Time_Known_Value (Rhs)
 808                then
 809                   Set_Current_Value (Ent, Rhs);
 810                else
 811                   Set_Current_Value (Ent, Empty);
 812                end if;
 813
 814             --  If not safe to capture values, kill them
 815
 816             else
 817                Kill_Lhs;
 818             end if;
 819          end;
 820       end if;
 821
 822       --  If assigning to an object in whole or in part, note location of
 823       --  assignment in case no one references value. We only do this for
 824       --  source assignments, otherwise we can generate bogus warnings when an
 825       --  assignment is rewritten as another assignment, and gets tied up with
 826       --  itself.
 827
 828       declare
 829          Ent : constant Entity_Id := Get_Enclosing_Object (Lhs);
 830       begin
 831          if Present (Ent)
 832            and then Safe_To_Capture_Value (N, Ent)
 833            and then Nkind (N) = N_Assignment_Statement
 834            and then Warn_On_Modified_Unread
 835            and then Is_Assignable (Ent)
 836            and then Comes_From_Source (N)
 837            and then In_Extended_Main_Source_Unit (Ent)
 838          then
 839             Set_Last_Assignment (Ent, Lhs);
 840          end if;
 841       end;
 842
 843       Analyze_Dimension (N);
 844    end Analyze_Assignment;
 845
 846    -----------------------------
 847    -- Analyze_Block_Statement --
 848    -----------------------------
 849
 850    procedure Analyze_Block_Statement (N : Node_Id) is
 851       procedure Install_Return_Entities (Scop : Entity_Id);
 852       --  Install all entities of return statement scope Scop in the visibility
 853       --  chain except for the return object since its entity is reused in a
 854       --  renaming.
 855
 856       -----------------------------
 857       -- Install_Return_Entities --
 858       -----------------------------
 859
 860       procedure Install_Return_Entities (Scop : Entity_Id) is
 861          Id : Entity_Id;
 862
 863       begin
 864          Id := First_Entity (Scop);
 865          while Present (Id) loop
 866
 867             --  Do not install the return object
 868
 869             if not Ekind_In (Id, E_Constant, E_Variable)
 870               or else not Is_Return_Object (Id)
 871             then
 872                Install_Entity (Id);
 873             end if;
 874
 875             Next_Entity (Id);
 876          end loop;
 877       end Install_Return_Entities;
 878
 879       --  Local constants and variables
 880
 881       Decls : constant List_Id := Declarations (N);
 882       Id    : constant Node_Id := Identifier (N);
 883       HSS   : constant Node_Id := Handled_Statement_Sequence (N);
 884
 885       Is_BIP_Return_Statement : Boolean;
 886
 887    --  Start of processing for Analyze_Block_Statement
 888
 889    begin
 890       --  In SPARK mode, we reject block statements. Note that the case of
 891       --  block statements generated by the expander is fine.
 892
 893       if Nkind (Original_Node (N)) = N_Block_Statement then
 894          Check_SPARK_Restriction ("block statement is not allowed", N);
 895       end if;
 896
 897       --  If no handled statement sequence is present, things are really messed
 898       --  up, and we just return immediately (defence against previous errors).
 899
 900       if No (HSS) then
 901          return;
 902       end if;
 903
 904       --  Detect whether the block is actually a rewritten return statement of
 905       --  a build-in-place function.
 906
 907       Is_BIP_Return_Statement :=
 908         Present (Id)
 909           and then Present (Entity (Id))
 910           and then Ekind (Entity (Id)) = E_Return_Statement
 911           and then Is_Build_In_Place_Function
 912                      (Return_Applies_To (Entity (Id)));
 913
 914       --  Normal processing with HSS present
 915
 916       declare
 917          EH  : constant List_Id := Exception_Handlers (HSS);
 918          Ent : Entity_Id        := Empty;
 919          S   : Entity_Id;
 920
 921          Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
 922          --  Recursively save value of this global, will be restored on exit
 923
 924       begin
 925          --  Initialize unblocked exit count for statements of begin block
 926          --  plus one for each exception handler that is present.
 927
 928          Unblocked_Exit_Count := 1;
 929
 930          if Present (EH) then
 931             Unblocked_Exit_Count := Unblocked_Exit_Count + List_Length (EH);
 932          end if;
 933
 934          --  If a label is present analyze it and mark it as referenced
 935
 936          if Present (Id) then
 937             Analyze (Id);
 938             Ent := Entity (Id);
 939
 940             --  An error defense. If we have an identifier, but no entity, then
 941             --  something is wrong. If previous errors, then just remove the
 942             --  identifier and continue, otherwise raise an exception.
 943
 944             if No (Ent) then
 945                if Total_Errors_Detected /= 0 then
 946                   Set_Identifier (N, Empty);
 947                else
 948                   raise Program_Error;
 949                end if;
 950
 951             else
 952                Set_Ekind (Ent, E_Block);
 953                Generate_Reference (Ent, N, ' ');
 954                Generate_Definition (Ent);
 955
 956                if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
 957                   Set_Label_Construct (Parent (Ent), N);
 958                end if;
 959             end if;
 960          end if;
 961
 962          --  If no entity set, create a label entity
 963
 964          if No (Ent) then
 965             Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
 966             Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N)));
 967             Set_Parent (Ent, N);
 968          end if;
 969
 970          Set_Etype (Ent, Standard_Void_Type);
 971          Set_Block_Node (Ent, Identifier (N));
 972          Push_Scope (Ent);
 973
 974          --  The block served as an extended return statement. Ensure that any
 975          --  entities created during the analysis and expansion of the return
 976          --  object declaration are once again visible.
 977
 978          if Is_BIP_Return_Statement then
 979             Install_Return_Entities (Ent);
 980          end if;
 981
 982          if Present (Decls) then
 983             Analyze_Declarations (Decls);
 984             Check_Completion;
 985             Inspect_Deferred_Constant_Completion (Decls);
 986          end if;
 987
 988          Analyze (HSS);
 989          Process_End_Label (HSS, 'e', Ent);
 990
 991          --  If exception handlers are present, then we indicate that enclosing
 992          --  scopes contain a block with handlers. We only need to mark non-
 993          --  generic scopes.
 994
 995          if Present (EH) then
 996             S := Scope (Ent);
 997             loop
 998                Set_Has_Nested_Block_With_Handler (S);
 999                exit when Is_Overloadable (S)
1000                  or else Ekind (S) = E_Package
1001                  or else Is_Generic_Unit (S);
1002                S := Scope (S);
1003             end loop;
1004          end if;
1005
1006          Check_References (Ent);
1007          Warn_On_Useless_Assignments (Ent);
1008          End_Scope;
1009
1010          if Unblocked_Exit_Count = 0 then
1011             Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1012             Check_Unreachable_Code (N);
1013          else
1014             Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1015          end if;
1016       end;
1017    end Analyze_Block_Statement;
1018
1019    ----------------------------
1020    -- Analyze_Case_Statement --
1021    ----------------------------
1022
1023    procedure Analyze_Case_Statement (N : Node_Id) is
1024       Exp            : Node_Id;
1025       Exp_Type       : Entity_Id;
1026       Exp_Btype      : Entity_Id;
1027       Last_Choice    : Nat;
1028       Dont_Care      : Boolean;
1029       Others_Present : Boolean;
1030
1031       pragma Warnings (Off, Last_Choice);
1032       pragma Warnings (Off, Dont_Care);
1033       --  Don't care about assigned values
1034
1035       Statements_Analyzed : Boolean := False;
1036       --  Set True if at least some statement sequences get analyzed. If False
1037       --  on exit, means we had a serious error that prevented full analysis of
1038       --  the case statement, and as a result it is not a good idea to output
1039       --  warning messages about unreachable code.
1040
1041       Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
1042       --  Recursively save value of this global, will be restored on exit
1043
1044       procedure Non_Static_Choice_Error (Choice : Node_Id);
1045       --  Error routine invoked by the generic instantiation below when the
1046       --  case statement has a non static choice.
1047
1048       procedure Process_Statements (Alternative : Node_Id);
1049       --  Analyzes all the statements associated with a case alternative.
1050       --  Needed by the generic instantiation below.
1051
1052       package Case_Choices_Processing is new
1053         Generic_Choices_Processing
1054           (Get_Alternatives          => Alternatives,
1055            Get_Choices               => Discrete_Choices,
1056            Process_Empty_Choice      => No_OP,
1057            Process_Non_Static_Choice => Non_Static_Choice_Error,
1058            Process_Associated_Node   => Process_Statements);
1059       use Case_Choices_Processing;
1060       --  Instantiation of the generic choice processing package
1061
1062       -----------------------------
1063       -- Non_Static_Choice_Error --
1064       -----------------------------
1065
1066       procedure Non_Static_Choice_Error (Choice : Node_Id) is
1067       begin
1068          Flag_Non_Static_Expr
1069            ("choice given in case statement is not static!", Choice);
1070       end Non_Static_Choice_Error;
1071
1072       ------------------------
1073       -- Process_Statements --
1074       ------------------------
1075
1076       procedure Process_Statements (Alternative : Node_Id) is
1077          Choices : constant List_Id := Discrete_Choices (Alternative);
1078          Ent     : Entity_Id;
1079
1080       begin
1081          Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
1082          Statements_Analyzed := True;
1083
1084          --  An interesting optimization. If the case statement expression
1085          --  is a simple entity, then we can set the current value within an
1086          --  alternative if the alternative has one possible value.
1087
1088          --    case N is
1089          --      when 1      => alpha
1090          --      when 2 | 3  => beta
1091          --      when others => gamma
1092
1093          --  Here we know that N is initially 1 within alpha, but for beta and
1094          --  gamma, we do not know anything more about the initial value.
1095
1096          if Is_Entity_Name (Exp) then
1097             Ent := Entity (Exp);
1098
1099             if Ekind_In (Ent, E_Variable,
1100                               E_In_Out_Parameter,
1101                               E_Out_Parameter)
1102             then
1103                if List_Length (Choices) = 1
1104                  and then Nkind (First (Choices)) in N_Subexpr
1105                  and then Compile_Time_Known_Value (First (Choices))
1106                then
1107                   Set_Current_Value (Entity (Exp), First (Choices));
1108                end if;
1109
1110                Analyze_Statements (Statements (Alternative));
1111
1112                --  After analyzing the case, set the current value to empty
1113                --  since we won't know what it is for the next alternative
1114                --  (unless reset by this same circuit), or after the case.
1115
1116                Set_Current_Value (Entity (Exp), Empty);
1117                return;
1118             end if;
1119          end if;
1120
1121          --  Case where expression is not an entity name of a variable
1122
1123          Analyze_Statements (Statements (Alternative));
1124       end Process_Statements;
1125
1126    --  Start of processing for Analyze_Case_Statement
1127
1128    begin
1129       Unblocked_Exit_Count := 0;
1130       Exp := Expression (N);
1131       Analyze (Exp);
1132
1133       --  The expression must be of any discrete type. In rare cases, the
1134       --  expander constructs a case statement whose expression has a private
1135       --  type whose full view is discrete. This can happen when generating
1136       --  a stream operation for a variant type after the type is frozen,
1137       --  when the partial of view of the type of the discriminant is private.
1138       --  In that case, use the full view to analyze case alternatives.
1139
1140       if not Is_Overloaded (Exp)
1141         and then not Comes_From_Source (N)
1142         and then Is_Private_Type (Etype (Exp))
1143         and then Present (Full_View (Etype (Exp)))
1144         and then Is_Discrete_Type (Full_View (Etype (Exp)))
1145       then
1146          Resolve (Exp, Etype (Exp));
1147          Exp_Type := Full_View (Etype (Exp));
1148
1149       else
1150          Analyze_And_Resolve (Exp, Any_Discrete);
1151          Exp_Type := Etype (Exp);
1152       end if;
1153
1154       Check_Unset_Reference (Exp);
1155       Exp_Btype := Base_Type (Exp_Type);
1156
1157       --  The expression must be of a discrete type which must be determinable
1158       --  independently of the context in which the expression occurs, but
1159       --  using the fact that the expression must be of a discrete type.
1160       --  Moreover, the type this expression must not be a character literal
1161       --  (which is always ambiguous) or, for Ada-83, a generic formal type.
1162
1163       --  If error already reported by Resolve, nothing more to do
1164
1165       if Exp_Btype = Any_Discrete
1166         or else Exp_Btype = Any_Type
1167       then
1168          return;
1169
1170       elsif Exp_Btype = Any_Character then
1171          Error_Msg_N
1172            ("character literal as case expression is ambiguous", Exp);
1173          return;
1174
1175       elsif Ada_Version = Ada_83
1176         and then (Is_Generic_Type (Exp_Btype)
1177                     or else Is_Generic_Type (Root_Type (Exp_Btype)))
1178       then
1179          Error_Msg_N
1180            ("(Ada 83) case expression cannot be of a generic type", Exp);
1181          return;
1182       end if;
1183
1184       --  If the case expression is a formal object of mode in out, then treat
1185       --  it as having a nonstatic subtype by forcing use of the base type
1186       --  (which has to get passed to Check_Case_Choices below). Also use base
1187       --  type when the case expression is parenthesized.
1188
1189       if Paren_Count (Exp) > 0
1190         or else (Is_Entity_Name (Exp)
1191                   and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter)
1192       then
1193          Exp_Type := Exp_Btype;
1194       end if;
1195
1196       --  Call instantiated Analyze_Choices which does the rest of the work
1197
1198       Analyze_Choices (N, Exp_Type, Dont_Care, Others_Present);
1199
1200       --  A case statement with a single OTHERS alternative is not allowed
1201       --  in SPARK.
1202
1203       if Others_Present
1204         and then List_Length (Alternatives (N)) = 1
1205       then
1206          Check_SPARK_Restriction
1207            ("OTHERS as unique case alternative is not allowed", N);
1208       end if;
1209
1210       if Exp_Type = Universal_Integer and then not Others_Present then
1211          Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
1212       end if;
1213
1214       --  If all our exits were blocked by unconditional transfers of control,
1215       --  then the entire CASE statement acts as an unconditional transfer of
1216       --  control, so treat it like one, and check unreachable code. Skip this
1217       --  test if we had serious errors preventing any statement analysis.
1218
1219       if Unblocked_Exit_Count = 0 and then Statements_Analyzed then
1220          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1221          Check_Unreachable_Code (N);
1222       else
1223          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1224       end if;
1225
1226       if not Expander_Active
1227         and then Compile_Time_Known_Value (Expression (N))
1228         and then Serious_Errors_Detected = 0
1229       then
1230          declare
1231             Chosen : constant Node_Id := Find_Static_Alternative (N);
1232             Alt    : Node_Id;
1233
1234          begin
1235             Alt := First (Alternatives (N));
1236             while Present (Alt) loop
1237                if Alt /= Chosen then
1238                   Remove_Warning_Messages (Statements (Alt));
1239                end if;
1240
1241                Next (Alt);
1242             end loop;
1243          end;
1244       end if;
1245    end Analyze_Case_Statement;
1246
1247    ----------------------------
1248    -- Analyze_Exit_Statement --
1249    ----------------------------
1250
1251    --  If the exit includes a name, it must be the name of a currently open
1252    --  loop. Otherwise there must be an innermost open loop on the stack, to
1253    --  which the statement implicitly refers.
1254
1255    --  Additionally, in SPARK mode:
1256
1257    --    The exit can only name the closest enclosing loop;
1258
1259    --    An exit with a when clause must be directly contained in a loop;
1260
1261    --    An exit without a when clause must be directly contained in an
1262    --    if-statement with no elsif or else, which is itself directly contained
1263    --    in a loop. The exit must be the last statement in the if-statement.
1264
1265    procedure Analyze_Exit_Statement (N : Node_Id) is
1266       Target   : constant Node_Id := Name (N);
1267       Cond     : constant Node_Id := Condition (N);
1268       Scope_Id : Entity_Id;
1269       U_Name   : Entity_Id;
1270       Kind     : Entity_Kind;
1271
1272    begin
1273       if No (Cond) then
1274          Check_Unreachable_Code (N);
1275       end if;
1276
1277       if Present (Target) then
1278          Analyze (Target);
1279          U_Name := Entity (Target);
1280
1281          if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
1282             Error_Msg_N ("invalid loop name in exit statement", N);
1283             return;
1284
1285          else
1286             if Has_Loop_In_Inner_Open_Scopes (U_Name) then
1287                Check_SPARK_Restriction
1288                  ("exit label must name the closest enclosing loop", N);
1289             end if;
1290
1291             Set_Has_Exit (U_Name);
1292          end if;
1293
1294       else
1295          U_Name := Empty;
1296       end if;
1297
1298       for J in reverse 0 .. Scope_Stack.Last loop
1299          Scope_Id := Scope_Stack.Table (J).Entity;
1300          Kind := Ekind (Scope_Id);
1301
1302          if Kind = E_Loop
1303            and then (No (Target) or else Scope_Id = U_Name)
1304          then
1305             Set_Has_Exit (Scope_Id);
1306             exit;
1307
1308          elsif Kind = E_Block
1309            or else Kind = E_Loop
1310            or else Kind = E_Return_Statement
1311          then
1312             null;
1313
1314          else
1315             Error_Msg_N
1316               ("cannot exit from program unit or accept statement", N);
1317             return;
1318          end if;
1319       end loop;
1320
1321       --  Verify that if present the condition is a Boolean expression
1322
1323       if Present (Cond) then
1324          Analyze_And_Resolve (Cond, Any_Boolean);
1325          Check_Unset_Reference (Cond);
1326       end if;
1327
1328       --  In SPARK mode, verify that the exit statement respects the SPARK
1329       --  restrictions.
1330
1331       if Present (Cond) then
1332          if Nkind (Parent (N)) /= N_Loop_Statement then
1333             Check_SPARK_Restriction
1334               ("exit with when clause must be directly in loop", N);
1335          end if;
1336
1337       else
1338          if Nkind (Parent (N)) /= N_If_Statement then
1339             if Nkind (Parent (N)) = N_Elsif_Part then
1340                Check_SPARK_Restriction
1341                  ("exit must be in IF without ELSIF", N);
1342             else
1343                Check_SPARK_Restriction ("exit must be directly in IF", N);
1344             end if;
1345
1346          elsif Nkind (Parent (Parent (N))) /= N_Loop_Statement then
1347             Check_SPARK_Restriction
1348               ("exit must be in IF directly in loop", N);
1349
1350          --  First test the presence of ELSE, so that an exit in an ELSE leads
1351          --  to an error mentioning the ELSE.
1352
1353          elsif Present (Else_Statements (Parent (N))) then
1354             Check_SPARK_Restriction ("exit must be in IF without ELSE", N);
1355
1356          --  An exit in an ELSIF does not reach here, as it would have been
1357          --  detected in the case (Nkind (Parent (N)) /= N_If_Statement).
1358
1359          elsif Present (Elsif_Parts (Parent (N))) then
1360             Check_SPARK_Restriction ("exit must be in IF without ELSIF", N);
1361          end if;
1362       end if;
1363
1364       --  Chain exit statement to associated loop entity
1365
1366       Set_Next_Exit_Statement  (N, First_Exit_Statement (Scope_Id));
1367       Set_First_Exit_Statement (Scope_Id, N);
1368
1369       --  Since the exit may take us out of a loop, any previous assignment
1370       --  statement is not useless, so clear last assignment indications. It
1371       --  is OK to keep other current values, since if the exit statement
1372       --  does not exit, then the current values are still valid.
1373
1374       Kill_Current_Values (Last_Assignment_Only => True);
1375    end Analyze_Exit_Statement;
1376
1377    ----------------------------
1378    -- Analyze_Goto_Statement --
1379    ----------------------------
1380
1381    procedure Analyze_Goto_Statement (N : Node_Id) is
1382       Label       : constant Node_Id := Name (N);
1383       Scope_Id    : Entity_Id;
1384       Label_Scope : Entity_Id;
1385       Label_Ent   : Entity_Id;
1386
1387    begin
1388       Check_SPARK_Restriction ("goto statement is not allowed", N);
1389
1390       --  Actual semantic checks
1391
1392       Check_Unreachable_Code (N);
1393       Kill_Current_Values (Last_Assignment_Only => True);
1394
1395       Analyze (Label);
1396       Label_Ent := Entity (Label);
1397
1398       --  Ignore previous error
1399
1400       if Label_Ent = Any_Id then
1401          return;
1402
1403       --  We just have a label as the target of a goto
1404
1405       elsif Ekind (Label_Ent) /= E_Label then
1406          Error_Msg_N ("target of goto statement must be a label", Label);
1407          return;
1408
1409       --  Check that the target of the goto is reachable according to Ada
1410       --  scoping rules. Note: the special gotos we generate for optimizing
1411       --  local handling of exceptions would violate these rules, but we mark
1412       --  such gotos as analyzed when built, so this code is never entered.
1413
1414       elsif not Reachable (Label_Ent) then
1415          Error_Msg_N ("target of goto statement is not reachable", Label);
1416          return;
1417       end if;
1418
1419       --  Here if goto passes initial validity checks
1420
1421       Label_Scope := Enclosing_Scope (Label_Ent);
1422
1423       for J in reverse 0 .. Scope_Stack.Last loop
1424          Scope_Id := Scope_Stack.Table (J).Entity;
1425
1426          if Label_Scope = Scope_Id
1427            or else (Ekind (Scope_Id) /= E_Block
1428                      and then Ekind (Scope_Id) /= E_Loop
1429                      and then Ekind (Scope_Id) /= E_Return_Statement)
1430          then
1431             if Scope_Id /= Label_Scope then
1432                Error_Msg_N
1433                  ("cannot exit from program unit or accept statement", N);
1434             end if;
1435
1436             return;
1437          end if;
1438       end loop;
1439
1440       raise Program_Error;
1441    end Analyze_Goto_Statement;
1442
1443    --------------------------
1444    -- Analyze_If_Statement --
1445    --------------------------
1446
1447    --  A special complication arises in the analysis of if statements
1448
1449    --  The expander has circuitry to completely delete code that it can tell
1450    --  will not be executed (as a result of compile time known conditions). In
1451    --  the analyzer, we ensure that code that will be deleted in this manner is
1452    --  analyzed but not expanded. This is obviously more efficient, but more
1453    --  significantly, difficulties arise if code is expanded and then
1454    --  eliminated (e.g. exception table entries disappear). Similarly, itypes
1455    --  generated in deleted code must be frozen from start, because the nodes
1456    --  on which they depend will not be available at the freeze point.
1457
1458    procedure Analyze_If_Statement (N : Node_Id) is
1459       E : Node_Id;
1460
1461       Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
1462       --  Recursively save value of this global, will be restored on exit
1463
1464       Save_In_Deleted_Code : Boolean;
1465
1466       Del : Boolean := False;
1467       --  This flag gets set True if a True condition has been found, which
1468       --  means that remaining ELSE/ELSIF parts are deleted.
1469
1470       procedure Analyze_Cond_Then (Cnode : Node_Id);
1471       --  This is applied to either the N_If_Statement node itself or to an
1472       --  N_Elsif_Part node. It deals with analyzing the condition and the THEN
1473       --  statements associated with it.
1474
1475       -----------------------
1476       -- Analyze_Cond_Then --
1477       -----------------------
1478
1479       procedure Analyze_Cond_Then (Cnode : Node_Id) is
1480          Cond : constant Node_Id := Condition (Cnode);
1481          Tstm : constant List_Id := Then_Statements (Cnode);
1482
1483       begin
1484          Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
1485          Analyze_And_Resolve (Cond, Any_Boolean);
1486          Check_Unset_Reference (Cond);
1487          Set_Current_Value_Condition (Cnode);
1488
1489          --  If already deleting, then just analyze then statements
1490
1491          if Del then
1492             Analyze_Statements (Tstm);
1493
1494          --  Compile time known value, not deleting yet
1495
1496          elsif Compile_Time_Known_Value (Cond) then
1497             Save_In_Deleted_Code := In_Deleted_Code;
1498
1499             --  If condition is True, then analyze the THEN statements and set
1500             --  no expansion for ELSE and ELSIF parts.
1501
1502             if Is_True (Expr_Value (Cond)) then
1503                Analyze_Statements (Tstm);
1504                Del := True;
1505                Expander_Mode_Save_And_Set (False);
1506                In_Deleted_Code := True;
1507
1508             --  If condition is False, analyze THEN with expansion off
1509
1510             else -- Is_False (Expr_Value (Cond))
1511                Expander_Mode_Save_And_Set (False);
1512                In_Deleted_Code := True;
1513                Analyze_Statements (Tstm);
1514                Expander_Mode_Restore;
1515                In_Deleted_Code := Save_In_Deleted_Code;
1516             end if;
1517
1518          --  Not known at compile time, not deleting, normal analysis
1519
1520          else
1521             Analyze_Statements (Tstm);
1522          end if;
1523       end Analyze_Cond_Then;
1524
1525    --  Start of Analyze_If_Statement
1526
1527    begin
1528       --  Initialize exit count for else statements. If there is no else part,
1529       --  this count will stay non-zero reflecting the fact that the uncovered
1530       --  else case is an unblocked exit.
1531
1532       Unblocked_Exit_Count := 1;
1533       Analyze_Cond_Then (N);
1534
1535       --  Now to analyze the elsif parts if any are present
1536
1537       if Present (Elsif_Parts (N)) then
1538          E := First (Elsif_Parts (N));
1539          while Present (E) loop
1540             Analyze_Cond_Then (E);
1541             Next (E);
1542          end loop;
1543       end if;
1544
1545       if Present (Else_Statements (N)) then
1546          Analyze_Statements (Else_Statements (N));
1547       end if;
1548
1549       --  If all our exits were blocked by unconditional transfers of control,
1550       --  then the entire IF statement acts as an unconditional transfer of
1551       --  control, so treat it like one, and check unreachable code.
1552
1553       if Unblocked_Exit_Count = 0 then
1554          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1555          Check_Unreachable_Code (N);
1556       else
1557          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
1558       end if;
1559
1560       if Del then
1561          Expander_Mode_Restore;
1562          In_Deleted_Code := Save_In_Deleted_Code;
1563       end if;
1564
1565       if not Expander_Active
1566         and then Compile_Time_Known_Value (Condition (N))
1567         and then Serious_Errors_Detected = 0
1568       then
1569          if Is_True (Expr_Value (Condition (N))) then
1570             Remove_Warning_Messages (Else_Statements (N));
1571
1572             if Present (Elsif_Parts (N)) then
1573                E := First (Elsif_Parts (N));
1574                while Present (E) loop
1575                   Remove_Warning_Messages (Then_Statements (E));
1576                   Next (E);
1577                end loop;
1578             end if;
1579
1580          else
1581             Remove_Warning_Messages (Then_Statements (N));
1582          end if;
1583       end if;
1584    end Analyze_If_Statement;
1585
1586    ----------------------------------------
1587    -- Analyze_Implicit_Label_Declaration --
1588    ----------------------------------------
1589
1590    --  An implicit label declaration is generated in the innermost enclosing
1591    --  declarative part. This is done for labels, and block and loop names.
1592
1593    --  Note: any changes in this routine may need to be reflected in
1594    --  Analyze_Label_Entity.
1595
1596    procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
1597       Id : constant Node_Id := Defining_Identifier (N);
1598    begin
1599       Enter_Name          (Id);
1600       Set_Ekind           (Id, E_Label);
1601       Set_Etype           (Id, Standard_Void_Type);
1602       Set_Enclosing_Scope (Id, Current_Scope);
1603    end Analyze_Implicit_Label_Declaration;
1604
1605    ------------------------------
1606    -- Analyze_Iteration_Scheme --
1607    ------------------------------
1608
1609    procedure Analyze_Iteration_Scheme (N : Node_Id) is
1610
1611       procedure Process_Bounds (R : Node_Id);
1612       --  If the iteration is given by a range, create temporaries and
1613       --  assignment statements block to capture the bounds and perform
1614       --  required finalization actions in case a bound includes a function
1615       --  call that uses the temporary stack. We first pre-analyze a copy of
1616       --  the range in order to determine the expected type, and analyze and
1617       --  resolve the original bounds.
1618
1619       procedure Check_Controlled_Array_Attribute (DS : Node_Id);
1620       --  If the bounds are given by a 'Range reference on a function call
1621       --  that returns a controlled array, introduce an explicit declaration
1622       --  to capture the bounds, so that the function result can be finalized
1623       --  in timely fashion.
1624
1625       function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean;
1626       --  N is the node for an arbitrary construct. This function searches the
1627       --  construct N to see if any expressions within it contain function
1628       --  calls that use the secondary stack, returning True if any such call
1629       --  is found, and False otherwise.
1630
1631       --------------------
1632       -- Process_Bounds --
1633       --------------------
1634
1635       procedure Process_Bounds (R : Node_Id) is
1636          Loc          : constant Source_Ptr := Sloc (N);
1637          R_Copy       : constant Node_Id := New_Copy_Tree (R);
1638          Lo           : constant Node_Id := Low_Bound  (R);
1639          Hi           : constant Node_Id := High_Bound (R);
1640          New_Lo_Bound : Node_Id;
1641          New_Hi_Bound : Node_Id;
1642          Typ          : Entity_Id;
1643
1644          function One_Bound
1645            (Original_Bound : Node_Id;
1646             Analyzed_Bound : Node_Id) return Node_Id;
1647          --  Capture value of bound and return captured value
1648
1649          ---------------
1650          -- One_Bound --
1651          ---------------
1652
1653          function One_Bound
1654            (Original_Bound : Node_Id;
1655             Analyzed_Bound : Node_Id) return Node_Id
1656          is
1657             Assign : Node_Id;
1658             Id     : Entity_Id;
1659             Decl   : Node_Id;
1660
1661          begin
1662             --  If the bound is a constant or an object, no need for a separate
1663             --  declaration. If the bound is the result of previous expansion
1664             --  it is already analyzed and should not be modified. Note that
1665             --  the Bound will be resolved later, if needed, as part of the
1666             --  call to Make_Index (literal bounds may need to be resolved to
1667             --  type Integer).
1668
1669             if Analyzed (Original_Bound) then
1670                return Original_Bound;
1671
1672             elsif Nkind_In (Analyzed_Bound, N_Integer_Literal,
1673                                             N_Character_Literal)
1674               or else Is_Entity_Name (Analyzed_Bound)
1675             then
1676                Analyze_And_Resolve (Original_Bound, Typ);
1677                return Original_Bound;
1678             end if;
1679
1680             --  Here we need to capture the value
1681
1682             Analyze_And_Resolve (Original_Bound, Typ);
1683
1684             --  Normally, the best approach is simply to generate a constant
1685             --  declaration that captures the bound. However, there is a nasty
1686             --  case where this is wrong. If the bound is complex, and has a
1687             --  possible use of the secondary stack, we need to generate a
1688             --  separate assignment statement to ensure the creation of a block
1689             --  which will release the secondary stack.
1690
1691             --  We prefer the constant declaration, since it leaves us with a
1692             --  proper trace of the value, useful in optimizations that get rid
1693             --  of junk range checks.
1694
1695             if not Has_Call_Using_Secondary_Stack (Original_Bound) then
1696                Force_Evaluation (Original_Bound);
1697                return Original_Bound;
1698             end if;
1699
1700             Id := Make_Temporary (Loc, 'R', Original_Bound);
1701
1702             --  Here we make a declaration with a separate assignment
1703             --  statement, and insert before loop header.
1704
1705             Decl :=
1706               Make_Object_Declaration (Loc,
1707                 Defining_Identifier => Id,
1708                 Object_Definition   => New_Occurrence_Of (Typ, Loc));
1709
1710             Assign :=
1711               Make_Assignment_Statement (Loc,
1712                 Name        => New_Occurrence_Of (Id, Loc),
1713                 Expression  => Relocate_Node (Original_Bound));
1714
1715             --  We must recursively clean in the relocated expression the flag
1716             --  analyzed to ensure that the expression is reanalyzed. Required
1717             --  to ensure that the transient scope is established now (because
1718             --  Establish_Transient_Scope discarded generating transient scopes
1719             --  in the analysis of the iteration scheme).
1720
1721             Reset_Analyzed_Flags (Expression (Assign));
1722
1723             Insert_Actions (Parent (N), New_List (Decl, Assign));
1724
1725             --  Now that this temporary variable is initialized we decorate it
1726             --  as safe-to-reevaluate to inform to the backend that no further
1727             --  asignment will be issued and hence it can be handled as side
1728             --  effect free. Note that this decoration must be done when the
1729             --  assignment has been analyzed because otherwise it will be
1730             --  rejected (see Analyze_Assignment).
1731
1732             Set_Is_Safe_To_Reevaluate (Id);
1733
1734             Rewrite (Original_Bound, New_Occurrence_Of (Id, Loc));
1735
1736             if Nkind (Assign) = N_Assignment_Statement then
1737                return Expression (Assign);
1738             else
1739                return Original_Bound;
1740             end if;
1741          end One_Bound;
1742
1743       --  Start of processing for Process_Bounds
1744
1745       begin
1746          Set_Parent (R_Copy, Parent (R));
1747          Pre_Analyze_Range (R_Copy);
1748          Typ := Etype (R_Copy);
1749
1750          --  If the type of the discrete range is Universal_Integer, then the
1751          --  bound's type must be resolved to Integer, and any object used to
1752          --  hold the bound must also have type Integer, unless the literal
1753          --  bounds are constant-folded expressions with a user-defined type.
1754
1755          if Typ = Universal_Integer then
1756             if Nkind (Lo) = N_Integer_Literal
1757               and then Present (Etype (Lo))
1758               and then Scope (Etype (Lo)) /= Standard_Standard
1759             then
1760                Typ := Etype (Lo);
1761
1762             elsif Nkind (Hi) = N_Integer_Literal
1763               and then Present (Etype (Hi))
1764               and then Scope (Etype (Hi)) /= Standard_Standard
1765             then
1766                Typ := Etype (Hi);
1767
1768             else
1769                Typ := Standard_Integer;
1770             end if;
1771          end if;
1772
1773          Set_Etype (R, Typ);
1774
1775          New_Lo_Bound := One_Bound (Lo, Low_Bound  (R_Copy));
1776          New_Hi_Bound := One_Bound (Hi, High_Bound (R_Copy));
1777
1778          --  Propagate staticness to loop range itself, in case the
1779          --  corresponding subtype is static.
1780
1781          if New_Lo_Bound /= Lo
1782            and then Is_Static_Expression (New_Lo_Bound)
1783          then
1784             Rewrite (Low_Bound (R), New_Copy (New_Lo_Bound));
1785          end if;
1786
1787          if New_Hi_Bound /= Hi
1788            and then Is_Static_Expression (New_Hi_Bound)
1789          then
1790             Rewrite (High_Bound (R), New_Copy (New_Hi_Bound));
1791          end if;
1792       end Process_Bounds;
1793
1794       --------------------------------------
1795       -- Check_Controlled_Array_Attribute --
1796       --------------------------------------
1797
1798       procedure Check_Controlled_Array_Attribute (DS : Node_Id) is
1799       begin
1800          if Nkind (DS) = N_Attribute_Reference
1801             and then Is_Entity_Name (Prefix (DS))
1802             and then Ekind (Entity (Prefix (DS))) = E_Function
1803             and then Is_Array_Type (Etype (Entity (Prefix (DS))))
1804             and then
1805               Is_Controlled (
1806                 Component_Type (Etype (Entity (Prefix (DS)))))
1807             and then Expander_Active
1808          then
1809             declare
1810                Loc  : constant Source_Ptr := Sloc (N);
1811                Arr  : constant Entity_Id := Etype (Entity (Prefix (DS)));
1812                Indx : constant Entity_Id :=
1813                         Base_Type (Etype (First_Index (Arr)));
1814                Subt : constant Entity_Id := Make_Temporary (Loc, 'S');
1815                Decl : Node_Id;
1816
1817             begin
1818                Decl :=
1819                  Make_Subtype_Declaration (Loc,
1820                    Defining_Identifier => Subt,
1821                    Subtype_Indication  =>
1822                       Make_Subtype_Indication (Loc,
1823                         Subtype_Mark  => New_Reference_To (Indx, Loc),
1824                         Constraint =>
1825                           Make_Range_Constraint (Loc,
1826                             Relocate_Node (DS))));
1827                Insert_Before (Parent (N), Decl);
1828                Analyze (Decl);
1829
1830                Rewrite (DS,
1831                   Make_Attribute_Reference (Loc,
1832                     Prefix => New_Reference_To (Subt, Loc),
1833                     Attribute_Name => Attribute_Name (DS)));
1834                Analyze (DS);
1835             end;
1836          end if;
1837       end Check_Controlled_Array_Attribute;
1838
1839       ------------------------------------
1840       -- Has_Call_Using_Secondary_Stack --
1841       ------------------------------------
1842
1843       function Has_Call_Using_Secondary_Stack (N : Node_Id) return Boolean is
1844
1845          function Check_Call (N : Node_Id) return Traverse_Result;
1846          --  Check if N is a function call which uses the secondary stack
1847
1848          ----------------
1849          -- Check_Call --
1850          ----------------
1851
1852          function Check_Call (N : Node_Id) return Traverse_Result is
1853             Nam        : Node_Id;
1854             Subp       : Entity_Id;
1855             Return_Typ : Entity_Id;
1856
1857          begin
1858             if Nkind (N) = N_Function_Call then
1859                Nam := Name (N);
1860
1861                --  Call using access to subprogram with explicit dereference
1862
1863                if Nkind (Nam) = N_Explicit_Dereference then
1864                   Subp := Etype (Nam);
1865
1866                --  Normal case
1867
1868                else
1869                   Subp := Entity (Nam);
1870                end if;
1871
1872                Return_Typ := Etype (Subp);
1873
1874                if Is_Composite_Type (Return_Typ)
1875                  and then not Is_Constrained (Return_Typ)
1876                then
1877                   return Abandon;
1878
1879                elsif Sec_Stack_Needed_For_Return (Subp) then
1880                   return Abandon;
1881                end if;
1882             end if;
1883
1884             --  Continue traversing the tree
1885
1886             return OK;
1887          end Check_Call;
1888
1889          function Check_Calls is new Traverse_Func (Check_Call);
1890
1891       --  Start of processing for Has_Call_Using_Secondary_Stack
1892
1893       begin
1894          return Check_Calls (N) = Abandon;
1895       end Has_Call_Using_Secondary_Stack;
1896
1897    --  Start of processing for Analyze_Iteration_Scheme
1898
1899    begin
1900       --  If this is a rewritten quantified expression, the iteration scheme
1901       --  has been analyzed already. Do no repeat analysis because the loop
1902       --  variable is already declared.
1903
1904       if Analyzed (N) then
1905          return;
1906       end if;
1907
1908       --  For an infinite loop, there is no iteration scheme
1909
1910       if No (N) then
1911          return;
1912       end if;
1913
1914       --  Iteration scheme is present
1915
1916       declare
1917          Cond : constant Node_Id := Condition (N);
1918
1919       begin
1920          --  For WHILE loop, verify that the condition is a Boolean expression
1921          --  and resolve and check it.
1922
1923          if Present (Cond) then
1924             Analyze_And_Resolve (Cond, Any_Boolean);
1925             Check_Unset_Reference (Cond);
1926             Set_Current_Value_Condition (N);
1927             return;
1928
1929          --  For an iterator specification with "of", pre-analyze range to
1930          --  capture function calls that may require finalization actions.
1931
1932          elsif Present (Iterator_Specification (N)) then
1933             Pre_Analyze_Range (Name (Iterator_Specification (N)));
1934             Analyze_Iterator_Specification (Iterator_Specification (N));
1935
1936          --  Else we have a FOR loop
1937
1938          else
1939             declare
1940                LP : constant Node_Id   := Loop_Parameter_Specification (N);
1941                Id : constant Entity_Id := Defining_Identifier (LP);
1942                DS : constant Node_Id   := Discrete_Subtype_Definition (LP);
1943
1944                D_Copy : Node_Id;
1945
1946             begin
1947                Enter_Name (Id);
1948
1949                --  We always consider the loop variable to be referenced, since
1950                --  the loop may be used just for counting purposes.
1951
1952                Generate_Reference (Id, N, ' ');
1953
1954                --  Check for the case of loop variable hiding a local variable
1955                --  (used later on to give a nice warning if the hidden variable
1956                --  is never assigned).
1957
1958                declare
1959                   H : constant Entity_Id := Homonym (Id);
1960                begin
1961                   if Present (H)
1962                     and then Enclosing_Dynamic_Scope (H) =
1963                                Enclosing_Dynamic_Scope (Id)
1964                     and then Ekind (H) = E_Variable
1965                     and then Is_Discrete_Type (Etype (H))
1966                   then
1967                      Set_Hiding_Loop_Variable (H, Id);
1968                   end if;
1969                end;
1970
1971                --  Loop parameter specification must include subtype mark in
1972                --  SPARK.
1973
1974                if Nkind (DS) = N_Range then
1975                   Check_SPARK_Restriction
1976                     ("loop parameter specification must include subtype mark",
1977                      N);
1978                end if;
1979
1980                --  Now analyze the subtype definition. If it is a range, create
1981                --  temporaries for bounds.
1982
1983                if Nkind (DS) = N_Range
1984                  and then Expander_Active
1985                then
1986                   Process_Bounds (DS);
1987
1988                --  Expander not active or else range of iteration is a subtype
1989                --  indication, an entity, or a function call that yields an
1990                --  aggregate or a container.
1991
1992                else
1993                   D_Copy := New_Copy_Tree (DS);
1994                   Set_Parent (D_Copy, Parent (DS));
1995                   Pre_Analyze_Range (D_Copy);
1996
1997                   --  Ada 2012: If the domain of iteration is a function call,
1998                   --  it is the new iterator form.
1999
2000                   --  We have also implemented the shorter form : for X in S
2001                   --  for Alfa use. In this case, 'Old and 'Result must be
2002                   --  treated as entity names over which iterators are legal.
2003
2004                   if Nkind (D_Copy) = N_Function_Call
2005                     or else
2006                       (Alfa_Mode
2007                         and then (Nkind (D_Copy) = N_Attribute_Reference
2008                         and then
2009                           (Attribute_Name (D_Copy) = Name_Result
2010                             or else Attribute_Name (D_Copy) = Name_Old)))
2011                     or else
2012                       (Is_Entity_Name (D_Copy)
2013                         and then not Is_Type (Entity (D_Copy)))
2014                   then
2015                      --  This is an iterator specification. Rewrite as such
2016                      --  and analyze, to capture function calls that may
2017                      --  require finalization actions.
2018
2019                      declare
2020                         I_Spec : constant Node_Id :=
2021                                    Make_Iterator_Specification (Sloc (LP),
2022                                      Defining_Identifier =>
2023                                        Relocate_Node (Id),
2024                                      Name                => D_Copy,
2025                                      Subtype_Indication  => Empty,
2026                                      Reverse_Present     =>
2027                                        Reverse_Present (LP));
2028                      begin
2029                         Set_Iterator_Specification (N, I_Spec);
2030                         Set_Loop_Parameter_Specification (N, Empty);
2031                         Analyze_Iterator_Specification (I_Spec);
2032
2033                         --  In a generic context, analyze the original domain
2034                         --  of iteration, for name capture.
2035
2036                         if not Expander_Active then
2037                            Analyze (DS);
2038                         end if;
2039
2040                         --  Set kind of loop parameter, which may be used in
2041                         --  the subsequent analysis of the condition in a
2042                         --  quantified expression.
2043
2044                         Set_Ekind (Id, E_Loop_Parameter);
2045                         return;
2046                      end;
2047
2048                   --  Domain of iteration is not a function call, and is
2049                   --  side-effect free.
2050
2051                   else
2052                      Analyze (DS);
2053                   end if;
2054                end if;
2055
2056                if DS = Error then
2057                   return;
2058                end if;
2059
2060                --  Some additional checks if we are iterating through a type
2061
2062                if Is_Entity_Name (DS)
2063                  and then Present (Entity (DS))
2064                  and then Is_Type (Entity (DS))
2065                then
2066                   --  The subtype indication may denote the completion of an
2067                   --  incomplete type declaration.
2068
2069                   if Ekind (Entity (DS)) = E_Incomplete_Type then
2070                      Set_Entity (DS, Get_Full_View (Entity (DS)));
2071                      Set_Etype  (DS, Entity (DS));
2072                   end if;
2073
2074                   --  Attempt to iterate through non-static predicate
2075
2076                   if Is_Discrete_Type (Entity (DS))
2077                     and then Present (Predicate_Function (Entity (DS)))
2078                     and then No (Static_Predicate (Entity (DS)))
2079                   then
2080                      Bad_Predicated_Subtype_Use
2081                        ("cannot use subtype& with non-static "
2082                         & "predicate for loop iteration", DS, Entity (DS));
2083                   end if;
2084                end if;
2085
2086                --  Error if not discrete type
2087
2088                if not Is_Discrete_Type (Etype (DS)) then
2089                   Wrong_Type (DS, Any_Discrete);
2090                   Set_Etype (DS, Any_Type);
2091                end if;
2092
2093                Check_Controlled_Array_Attribute (DS);
2094
2095                Make_Index (DS, LP, In_Iter_Schm => True);
2096
2097                Set_Ekind (Id, E_Loop_Parameter);
2098
2099                --  If the loop is part of a predicate or precondition, it may
2100                --  be analyzed twice, once in the source and once on the copy
2101                --  used to check conformance. Preserve the original itype
2102                --  because the second one may be created in a different scope,
2103                --  e.g. a precondition procedure, leading to a crash in GIGI.
2104
2105                if No (Etype (Id)) or else Etype (Id) = Any_Type then
2106                   Set_Etype (Id, Etype (DS));
2107                end if;
2108
2109                --  Treat a range as an implicit reference to the type, to
2110                --  inhibit spurious warnings.
2111
2112                Generate_Reference (Base_Type (Etype (DS)), N, ' ');
2113                Set_Is_Known_Valid (Id, True);
2114
2115                --  The loop is not a declarative part, so the only entity
2116                --  declared "within" must be frozen explicitly.
2117
2118                declare
2119                   Flist : constant List_Id := Freeze_Entity (Id, N);
2120                begin
2121                   if Is_Non_Empty_List (Flist) then
2122                      Insert_Actions (N, Flist);
2123                   end if;
2124                end;
2125
2126                --  Check for null or possibly null range and issue warning. We
2127                --  suppress such messages in generic templates and instances,
2128                --  because in practice they tend to be dubious in these cases.
2129
2130                if Nkind (DS) = N_Range and then Comes_From_Source (N) then
2131                   declare
2132                      L : constant Node_Id := Low_Bound  (DS);
2133                      H : constant Node_Id := High_Bound (DS);
2134
2135                   begin
2136                      --  If range of loop is null, issue warning
2137
2138                      if Compile_Time_Compare
2139                           (L, H, Assume_Valid => True) = GT
2140                      then
2141                         --  Suppress the warning if inside a generic template
2142                         --  or instance, since in practice they tend to be
2143                         --  dubious in these cases since they can result from
2144                         --  intended parametrization.
2145
2146                         if not Inside_A_Generic
2147                           and then not In_Instance
2148                         then
2149                            --  Specialize msg if invalid values could make the
2150                            --  loop non-null after all.
2151
2152                            if Compile_Time_Compare
2153                                 (L, H, Assume_Valid => False) = GT
2154                            then
2155                               Error_Msg_N
2156                                 ("?loop range is null, loop will not execute",
2157                                  DS);
2158
2159                               --  Since we know the range of the loop is null,
2160                               --  set the appropriate flag to remove the loop
2161                               --  entirely during expansion.
2162
2163                               Set_Is_Null_Loop (Parent (N));
2164
2165                               --  Here is where the loop could execute because
2166                               --  of invalid values, so issue appropriate
2167                               --  message and in this case we do not set the
2168                               --  Is_Null_Loop flag since the loop may execute.
2169
2170                            else
2171                               Error_Msg_N
2172                                 ("?loop range may be null, "
2173                                  & "loop may not execute",
2174                                  DS);
2175                               Error_Msg_N
2176                                 ("?can only execute if invalid values "
2177                                  & "are present",
2178                                  DS);
2179                            end if;
2180                         end if;
2181
2182                         --  In either case, suppress warnings in the body of
2183                         --  the loop, since it is likely that these warnings
2184                         --  will be inappropriate if the loop never actually
2185                         --  executes, which is likely.
2186
2187                         Set_Suppress_Loop_Warnings (Parent (N));
2188
2189                         --  The other case for a warning is a reverse loop
2190                         --  where the upper bound is the integer literal zero
2191                         --  or one, and the lower bound can be positive.
2192
2193                         --  For example, we have
2194
2195                         --     for J in reverse N .. 1 loop
2196
2197                         --  In practice, this is very likely to be a case of
2198                         --  reversing the bounds incorrectly in the range.
2199
2200                      elsif Reverse_Present (LP)
2201                        and then Nkind (Original_Node (H)) =
2202                                                       N_Integer_Literal
2203                        and then (Intval (Original_Node (H)) = Uint_0
2204                                   or else
2205                                     Intval (Original_Node (H)) = Uint_1)
2206                      then
2207                         Error_Msg_N ("?loop range may be null", DS);
2208                         Error_Msg_N ("\?bounds may be wrong way round", DS);
2209                      end if;
2210                   end;
2211                end if;
2212             end;
2213          end if;
2214       end;
2215    end Analyze_Iteration_Scheme;
2216
2217    -------------------------------------
2218    --  Analyze_Iterator_Specification --
2219    -------------------------------------
2220
2221    procedure Analyze_Iterator_Specification (N : Node_Id) is
2222       Loc       : constant Source_Ptr := Sloc (N);
2223       Def_Id    : constant Node_Id    := Defining_Identifier (N);
2224       Subt      : constant Node_Id    := Subtype_Indication (N);
2225       Iter_Name : constant Node_Id    := Name (N);
2226
2227       Ent : Entity_Id;
2228       Typ : Entity_Id;
2229
2230    begin
2231       --  In semantics/Alfa modes, we won't be further expanding the loop, so
2232       --  introduce loop variable so that loop body can be properly analyzed.
2233       --  Otherwise this happens after expansion.
2234
2235       if Operating_Mode = Check_Semantics
2236         or else Alfa_Mode
2237       then
2238          Enter_Name (Def_Id);
2239       end if;
2240
2241       Set_Ekind (Def_Id, E_Variable);
2242
2243       if Present (Subt) then
2244          Analyze (Subt);
2245       end if;
2246
2247       --  If domain of iteration is an expression, create a declaration for
2248       --  it, so that finalization actions are introduced outside of the loop.
2249       --  The declaration must be a renaming because the body of the loop may
2250       --  assign to elements.
2251
2252       if not Is_Entity_Name (Iter_Name) then
2253          declare
2254             Id   : constant Entity_Id := Make_Temporary (Loc, 'R', Iter_Name);
2255             Decl : Node_Id;
2256
2257          begin
2258             Typ := Etype (Iter_Name);
2259
2260             --  The name in the renaming declaration may be a function call.
2261             --  Indicate that it does not come from source, to suppress
2262             --  spurious warnings on renamings of parameterless functions,
2263             --  a common enough idiom in user-defined iterators.
2264
2265             Decl :=
2266               Make_Object_Renaming_Declaration (Loc,
2267                 Defining_Identifier => Id,
2268                 Subtype_Mark        => New_Occurrence_Of (Typ, Loc),
2269                 Name                =>
2270                   New_Copy_Tree (Iter_Name, New_Sloc => Loc));
2271
2272             Insert_Actions (Parent (Parent (N)), New_List (Decl));
2273             Rewrite (Name (N), New_Occurrence_Of (Id, Loc));
2274             Set_Etype (Id, Typ);
2275             Set_Etype (Name (N), Typ);
2276          end;
2277
2278       --  Container is an entity or an array with uncontrolled components, or
2279       --  else it is a container iterator given by a function call, typically
2280       --  called Iterate in the case of predefined containers, even though
2281       --  Iterate is not a reserved name. What matter is that the return type
2282       --  of the function is an iterator type.
2283
2284       else
2285          Analyze (Iter_Name);
2286
2287          if Nkind (Iter_Name) = N_Function_Call then
2288             declare
2289                C  : constant Node_Id := Name (Iter_Name);
2290                I  : Interp_Index;
2291                It : Interp;
2292
2293             begin
2294                if not Is_Overloaded (Iter_Name) then
2295                   Resolve (Iter_Name, Etype (C));
2296
2297                else
2298                   Get_First_Interp (C, I, It);
2299                   while It.Typ /= Empty loop
2300                      if Reverse_Present (N) then
2301                         if Is_Reversible_Iterator (It.Typ) then
2302                            Resolve (Iter_Name, It.Typ);
2303                            exit;
2304                         end if;
2305
2306                      elsif Is_Iterator (It.Typ) then
2307                         Resolve (Iter_Name, It.Typ);
2308                         exit;
2309                      end if;
2310
2311                      Get_Next_Interp (I, It);
2312                   end loop;
2313                end if;
2314             end;
2315
2316          --  Domain of iteration is not overloaded
2317
2318          else
2319             Resolve (Iter_Name, Etype (Iter_Name));
2320          end if;
2321       end if;
2322
2323       Typ := Etype (Iter_Name);
2324
2325       if Is_Array_Type (Typ) then
2326          if Of_Present (N) then
2327             Set_Etype (Def_Id, Component_Type (Typ));
2328
2329          --  Here we have a missing Range attribute
2330
2331          else
2332             Error_Msg_N
2333               ("missing Range attribute in iteration over an array", N);
2334
2335             --  In Ada 2012 mode, this may be an attempt at an iterator
2336
2337             if Ada_Version >= Ada_2012 then
2338                Error_Msg_NE
2339                  ("\if& is meant to designate an element of the array, use OF",
2340                     N, Def_Id);
2341             end if;
2342
2343             --  Prevent cascaded errors
2344
2345             Set_Ekind (Def_Id, E_Loop_Parameter);
2346             Set_Etype (Def_Id, Etype (First_Index (Typ)));
2347          end if;
2348
2349          --  Check for type error in iterator
2350
2351       elsif Typ = Any_Type then
2352          return;
2353
2354       --  Iteration over a container
2355
2356       else
2357          Set_Ekind (Def_Id, E_Loop_Parameter);
2358
2359          if Of_Present (N) then
2360
2361             --  The type of the loop variable is the Iterator_Element aspect of
2362             --  the container type.
2363
2364             declare
2365                Element : constant Entity_Id :=
2366                            Find_Aspect (Typ, Aspect_Iterator_Element);
2367             begin
2368                if No (Element) then
2369                   Error_Msg_NE ("cannot iterate over&", N, Typ);
2370                   return;
2371                else
2372                   Set_Etype (Def_Id, Entity (Element));
2373                end if;
2374             end;
2375
2376          else
2377             --  For an iteration of the form IN, the name must denote an
2378             --  iterator, typically the result of a call to Iterate. Give a
2379             --  useful error message when the name is a container by itself.
2380
2381             if Is_Entity_Name (Original_Node (Name (N)))
2382               and then not Is_Iterator (Typ)
2383             then
2384                if No (Find_Aspect (Typ, Aspect_Iterator_Element)) then
2385                   Error_Msg_NE
2386                     ("cannot iterate over&", Name (N), Typ);
2387                else
2388                   Error_Msg_N
2389                     ("name must be an iterator, not a container", Name (N));
2390                end if;
2391
2392                Error_Msg_NE
2393                  ("\to iterate directly over the elements of a container, " &
2394                    "write `of &`", Name (N), Original_Node (Name (N)));
2395             end if;
2396
2397             --  The result type of Iterate function is the classwide type of
2398             --  the interface parent. We need the specific Cursor type defined
2399             --  in the container package.
2400
2401             Ent := First_Entity (Scope (Typ));
2402             while Present (Ent) loop
2403                if Chars (Ent) = Name_Cursor then
2404                   Set_Etype (Def_Id, Etype (Ent));
2405                   exit;
2406                end if;
2407
2408                Next_Entity (Ent);
2409             end loop;
2410          end if;
2411       end if;
2412    end Analyze_Iterator_Specification;
2413
2414    -------------------
2415    -- Analyze_Label --
2416    -------------------
2417
2418    --  Note: the semantic work required for analyzing labels (setting them as
2419    --  reachable) was done in a prepass through the statements in the block,
2420    --  so that forward gotos would be properly handled. See Analyze_Statements
2421    --  for further details. The only processing required here is to deal with
2422    --  optimizations that depend on an assumption of sequential control flow,
2423    --  since of course the occurrence of a label breaks this assumption.
2424
2425    procedure Analyze_Label (N : Node_Id) is
2426       pragma Warnings (Off, N);
2427    begin
2428       Kill_Current_Values;
2429    end Analyze_Label;
2430
2431    --------------------------
2432    -- Analyze_Label_Entity --
2433    --------------------------
2434
2435    procedure Analyze_Label_Entity (E : Entity_Id) is
2436    begin
2437       Set_Ekind           (E, E_Label);
2438       Set_Etype           (E, Standard_Void_Type);
2439       Set_Enclosing_Scope (E, Current_Scope);
2440       Set_Reachable       (E, True);
2441    end Analyze_Label_Entity;
2442
2443    ----------------------------
2444    -- Analyze_Loop_Statement --
2445    ----------------------------
2446
2447    procedure Analyze_Loop_Statement (N : Node_Id) is
2448
2449       function Is_Container_Iterator (Iter : Node_Id) return Boolean;
2450       --  Given a loop iteration scheme, determine whether it is an Ada 2012
2451       --  container iteration.
2452
2453       function Is_Wrapped_In_Block (N : Node_Id) return Boolean;
2454       --  Determine whether node N is the sole statement of a block
2455
2456       ---------------------------
2457       -- Is_Container_Iterator --
2458       ---------------------------
2459
2460       function Is_Container_Iterator (Iter : Node_Id) return Boolean is
2461       begin
2462          --  Infinite loop
2463
2464          if No (Iter) then
2465             return False;
2466
2467          --  While loop
2468
2469          elsif Present (Condition (Iter)) then
2470             return False;
2471
2472          --  for Def_Id in [reverse] Name loop
2473          --  for Def_Id [: Subtype_Indication] of [reverse] Name loop
2474
2475          elsif Present (Iterator_Specification (Iter)) then
2476             declare
2477                Nam : constant Node_Id := Name (Iterator_Specification (Iter));
2478                Nam_Copy : Node_Id;
2479
2480             begin
2481                Nam_Copy := New_Copy_Tree (Nam);
2482                Set_Parent (Nam_Copy, Parent (Nam));
2483                Pre_Analyze_Range (Nam_Copy);
2484
2485                --  The only two options here are iteration over a container or
2486                --  an array.
2487
2488                return not Is_Array_Type (Etype (Nam_Copy));
2489             end;
2490
2491          --  for Def_Id in [reverse] Discrete_Subtype_Definition loop
2492
2493          else
2494             declare
2495                LP : constant Node_Id := Loop_Parameter_Specification (Iter);
2496                DS : constant Node_Id := Discrete_Subtype_Definition (LP);
2497                DS_Copy : Node_Id;
2498
2499             begin
2500                DS_Copy := New_Copy_Tree (DS);
2501                Set_Parent (DS_Copy, Parent (DS));
2502                Pre_Analyze_Range (DS_Copy);
2503
2504                --  Check for a call to Iterate ()
2505
2506                return
2507                  Nkind (DS_Copy) = N_Function_Call
2508                    and then Needs_Finalization (Etype (DS_Copy));
2509             end;
2510          end if;
2511       end Is_Container_Iterator;
2512
2513       -------------------------
2514       -- Is_Wrapped_In_Block --
2515       -------------------------
2516
2517       function Is_Wrapped_In_Block (N : Node_Id) return Boolean is
2518          HSS : constant Node_Id := Parent (N);
2519
2520       begin
2521          return
2522            Nkind (HSS) = N_Handled_Sequence_Of_Statements
2523              and then Nkind (Parent (HSS)) = N_Block_Statement
2524              and then First (Statements (HSS)) = N
2525              and then No (Next (First (Statements (HSS))));
2526       end Is_Wrapped_In_Block;
2527
2528       --  Local declarations
2529
2530       Id   : constant Node_Id := Identifier (N);
2531       Iter : constant Node_Id := Iteration_Scheme (N);
2532       Loc  : constant Source_Ptr := Sloc (N);
2533       Ent  : Entity_Id;
2534
2535    --  Start of processing for Analyze_Loop_Statement
2536
2537    begin
2538       if Present (Id) then
2539
2540          --  Make name visible, e.g. for use in exit statements. Loop labels
2541          --  are always considered to be referenced.
2542
2543          Analyze (Id);
2544          Ent := Entity (Id);
2545
2546          --  Guard against serious error (typically, a scope mismatch when
2547          --  semantic analysis is requested) by creating loop entity to
2548          --  continue analysis.
2549
2550          if No (Ent) then
2551             if Total_Errors_Detected /= 0 then
2552                Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
2553             else
2554                raise Program_Error;
2555             end if;
2556
2557          else
2558             Generate_Reference (Ent, N, ' ');
2559             Generate_Definition (Ent);
2560
2561             --  If we found a label, mark its type. If not, ignore it, since it
2562             --  means we have a conflicting declaration, which would already
2563             --  have been diagnosed at declaration time. Set Label_Construct
2564             --  of the implicit label declaration, which is not created by the
2565             --  parser for generic units.
2566
2567             if Ekind (Ent) = E_Label then
2568                Set_Ekind (Ent, E_Loop);
2569
2570                if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
2571                   Set_Label_Construct (Parent (Ent), N);
2572                end if;
2573             end if;
2574          end if;
2575
2576       --  Case of no identifier present
2577
2578       else
2579          Ent := New_Internal_Entity (E_Loop, Current_Scope, Loc, 'L');
2580          Set_Etype  (Ent, Standard_Void_Type);
2581          Set_Parent (Ent, N);
2582       end if;
2583
2584       --  Iteration over a container in Ada 2012 involves the creation of a
2585       --  controlled iterator object. Wrap the loop in a block to ensure the
2586       --  timely finalization of the iterator and release of container locks.
2587
2588       if Ada_Version >= Ada_2012
2589         and then Is_Container_Iterator (Iter)
2590         and then not Is_Wrapped_In_Block (N)
2591       then
2592          Rewrite (N,
2593            Make_Block_Statement (Loc,
2594              Declarations               => New_List,
2595              Handled_Statement_Sequence =>
2596                Make_Handled_Sequence_Of_Statements (Loc,
2597                  Statements => New_List (Relocate_Node (N)))));
2598
2599          Analyze (N);
2600          return;
2601       end if;
2602
2603       --  Kill current values on entry to loop, since statements in the body of
2604       --  the loop may have been executed before the loop is entered. Similarly
2605       --  we kill values after the loop, since we do not know that the body of
2606       --  the loop was executed.
2607
2608       Kill_Current_Values;
2609       Push_Scope (Ent);
2610       Analyze_Iteration_Scheme (Iter);
2611
2612       --  Analyze the statements of the body except in the case of an Ada 2012
2613       --  iterator with the expander active. In this case the expander will do
2614       --  a rewrite of the loop into a while loop. We will then analyze the
2615       --  loop body when we analyze this while loop.
2616
2617       --  We need to do this delay because if the container is for indefinite
2618       --  types the actual subtype of the components will only be determined
2619       --  when the cursor declaration is analyzed.
2620
2621       --  If the expander is not active, then we want to analyze the loop body
2622       --  now even in the Ada 2012 iterator case, since the rewriting will not
2623       --  be done. Insert the loop variable in the current scope, if not done
2624       --  when analysing the iteration scheme.
2625
2626       if No (Iter)
2627         or else No (Iterator_Specification (Iter))
2628         or else not Expander_Active
2629       then
2630          if Present (Iter)
2631            and then Present (Iterator_Specification (Iter))
2632          then
2633             declare
2634                Id : constant Entity_Id :=
2635                       Defining_Identifier (Iterator_Specification (Iter));
2636             begin
2637                if Scope (Id) /= Current_Scope then
2638                   Enter_Name (Id);
2639                end if;
2640             end;
2641          end if;
2642
2643          Analyze_Statements (Statements (N));
2644       end if;
2645
2646       --  Finish up processing for the loop. We kill all current values, since
2647       --  in general we don't know if the statements in the loop have been
2648       --  executed. We could do a bit better than this with a loop that we
2649       --  know will execute at least once, but it's not worth the trouble and
2650       --  the front end is not in the business of flow tracing.
2651
2652       Process_End_Label (N, 'e', Ent);
2653       End_Scope;
2654       Kill_Current_Values;
2655
2656       --  Check for infinite loop. Skip check for generated code, since it
2657       --  justs waste time and makes debugging the routine called harder.
2658
2659       --  Note that we have to wait till the body of the loop is fully analyzed
2660       --  before making this call, since Check_Infinite_Loop_Warning relies on
2661       --  being able to use semantic visibility information to find references.
2662
2663       if Comes_From_Source (N) then
2664          Check_Infinite_Loop_Warning (N);
2665       end if;
2666
2667       --  Code after loop is unreachable if the loop has no WHILE or FOR and
2668       --  contains no EXIT statements within the body of the loop.
2669
2670       if No (Iter) and then not Has_Exit (Ent) then
2671          Check_Unreachable_Code (N);
2672       end if;
2673    end Analyze_Loop_Statement;
2674
2675    ----------------------------
2676    -- Analyze_Null_Statement --
2677    ----------------------------
2678
2679    --  Note: the semantics of the null statement is implemented by a single
2680    --  null statement, too bad everything isn't as simple as this!
2681
2682    procedure Analyze_Null_Statement (N : Node_Id) is
2683       pragma Warnings (Off, N);
2684    begin
2685       null;
2686    end Analyze_Null_Statement;
2687
2688    ------------------------
2689    -- Analyze_Statements --
2690    ------------------------
2691
2692    procedure Analyze_Statements (L : List_Id) is
2693       S   : Node_Id;
2694       Lab : Entity_Id;
2695
2696    begin
2697       --  The labels declared in the statement list are reachable from
2698       --  statements in the list. We do this as a prepass so that any goto
2699       --  statement will be properly flagged if its target is not reachable.
2700       --  This is not required, but is nice behavior!
2701
2702       S := First (L);
2703       while Present (S) loop
2704          if Nkind (S) = N_Label then
2705             Analyze (Identifier (S));
2706             Lab := Entity (Identifier (S));
2707
2708             --  If we found a label mark it as reachable
2709
2710             if Ekind (Lab) = E_Label then
2711                Generate_Definition (Lab);
2712                Set_Reachable (Lab);
2713
2714                if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
2715                   Set_Label_Construct (Parent (Lab), S);
2716                end if;
2717
2718             --  If we failed to find a label, it means the implicit declaration
2719             --  of the label was hidden.  A for-loop parameter can do this to
2720             --  a label with the same name inside the loop, since the implicit
2721             --  label declaration is in the innermost enclosing body or block
2722             --  statement.
2723
2724             else
2725                Error_Msg_Sloc := Sloc (Lab);
2726                Error_Msg_N
2727                  ("implicit label declaration for & is hidden#",
2728                   Identifier (S));
2729             end if;
2730          end if;
2731
2732          Next (S);
2733       end loop;
2734
2735       --  Perform semantic analysis on all statements
2736
2737       Conditional_Statements_Begin;
2738
2739       S := First (L);
2740       while Present (S) loop
2741          Analyze (S);
2742
2743          --  Remove dimension in all statements
2744
2745          Remove_Dimension_In_Statement (S);
2746          Next (S);
2747       end loop;
2748
2749       Conditional_Statements_End;
2750
2751       --  Make labels unreachable. Visibility is not sufficient, because labels
2752       --  in one if-branch for example are not reachable from the other branch,
2753       --  even though their declarations are in the enclosing declarative part.
2754
2755       S := First (L);
2756       while Present (S) loop
2757          if Nkind (S) = N_Label then
2758             Set_Reachable (Entity (Identifier (S)), False);
2759          end if;
2760
2761          Next (S);
2762       end loop;
2763    end Analyze_Statements;
2764
2765    ----------------------------
2766    -- Check_Unreachable_Code --
2767    ----------------------------
2768
2769    procedure Check_Unreachable_Code (N : Node_Id) is
2770       Error_Node : Node_Id;
2771       P          : Node_Id;
2772
2773    begin
2774       if Is_List_Member (N)
2775         and then Comes_From_Source (N)
2776       then
2777          declare
2778             Nxt : Node_Id;
2779
2780          begin
2781             Nxt := Original_Node (Next (N));
2782
2783             --  If a label follows us, then we never have dead code, since
2784             --  someone could branch to the label, so we just ignore it, unless
2785             --  we are in formal mode where goto statements are not allowed.
2786
2787             if Nkind (Nxt) = N_Label
2788               and then not Restriction_Check_Required (SPARK)
2789             then
2790                return;
2791
2792             --  Otherwise see if we have a real statement following us
2793
2794             elsif Present (Nxt)
2795               and then Comes_From_Source (Nxt)
2796               and then Is_Statement (Nxt)
2797             then
2798                --  Special very annoying exception. If we have a return that
2799                --  follows a raise, then we allow it without a warning, since
2800                --  the Ada RM annoyingly requires a useless return here!
2801
2802                if Nkind (Original_Node (N)) /= N_Raise_Statement
2803                  or else Nkind (Nxt) /= N_Simple_Return_Statement
2804                then
2805                   --  The rather strange shenanigans with the warning message
2806                   --  here reflects the fact that Kill_Dead_Code is very good
2807                   --  at removing warnings in deleted code, and this is one
2808                   --  warning we would prefer NOT to have removed.
2809
2810                   Error_Node := Nxt;
2811
2812                   --  If we have unreachable code, analyze and remove the
2813                   --  unreachable code, since it is useless and we don't
2814                   --  want to generate junk warnings.
2815
2816                   --  We skip this step if we are not in code generation mode.
2817                   --  This is the one case where we remove dead code in the
2818                   --  semantics as opposed to the expander, and we do not want
2819                   --  to remove code if we are not in code generation mode,
2820                   --  since this messes up the ASIS trees.
2821
2822                   --  Note that one might react by moving the whole circuit to
2823                   --  exp_ch5, but then we lose the warning in -gnatc mode.
2824
2825                   if Operating_Mode = Generate_Code then
2826                      loop
2827                         Nxt := Next (N);
2828
2829                         --  Quit deleting when we have nothing more to delete
2830                         --  or if we hit a label (since someone could transfer
2831                         --  control to a label, so we should not delete it).
2832
2833                         exit when No (Nxt) or else Nkind (Nxt) = N_Label;
2834
2835                         --  Statement/declaration is to be deleted
2836
2837                         Analyze (Nxt);
2838                         Remove (Nxt);
2839                         Kill_Dead_Code (Nxt);
2840                      end loop;
2841                   end if;
2842
2843                   --  Now issue the warning (or error in formal mode)
2844
2845                   if Restriction_Check_Required (SPARK) then
2846                      Check_SPARK_Restriction
2847                        ("unreachable code is not allowed", Error_Node);
2848                   else
2849                      Error_Msg ("?unreachable code!", Sloc (Error_Node));
2850                   end if;
2851                end if;
2852
2853             --  If the unconditional transfer of control instruction is the
2854             --  last statement of a sequence, then see if our parent is one of
2855             --  the constructs for which we count unblocked exits, and if so,
2856             --  adjust the count.
2857
2858             else
2859                P := Parent (N);
2860
2861                --  Statements in THEN part or ELSE part of IF statement
2862
2863                if Nkind (P) = N_If_Statement then
2864                   null;
2865
2866                --  Statements in ELSIF part of an IF statement
2867
2868                elsif Nkind (P) = N_Elsif_Part then
2869                   P := Parent (P);
2870                   pragma Assert (Nkind (P) = N_If_Statement);
2871
2872                --  Statements in CASE statement alternative
2873
2874                elsif Nkind (P) = N_Case_Statement_Alternative then
2875                   P := Parent (P);
2876                   pragma Assert (Nkind (P) = N_Case_Statement);
2877
2878                --  Statements in body of block
2879
2880                elsif Nkind (P) = N_Handled_Sequence_Of_Statements
2881                  and then Nkind (Parent (P)) = N_Block_Statement
2882                then
2883                   null;
2884
2885                --  Statements in exception handler in a block
2886
2887                elsif Nkind (P) = N_Exception_Handler
2888                  and then Nkind (Parent (P)) = N_Handled_Sequence_Of_Statements
2889                  and then Nkind (Parent (Parent (P))) = N_Block_Statement
2890                then
2891                   null;
2892
2893                --  None of these cases, so return
2894
2895                else
2896                   return;
2897                end if;
2898
2899                --  This was one of the cases we are looking for (i.e. the
2900                --  parent construct was IF, CASE or block) so decrement count.
2901
2902                Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
2903             end if;
2904          end;
2905       end if;
2906    end Check_Unreachable_Code;
2907
2908    -----------------------
2909    -- Pre_Analyze_Range --
2910    -----------------------
2911
2912    procedure Pre_Analyze_Range (R_Copy : Node_Id) is
2913       Save_Analysis : constant Boolean := Full_Analysis;
2914
2915    begin
2916       Full_Analysis := False;
2917       Expander_Mode_Save_And_Set (False);
2918
2919       Analyze (R_Copy);
2920
2921       if Nkind (R_Copy) in N_Subexpr
2922         and then Is_Overloaded (R_Copy)
2923       then
2924          --  Apply preference rules for range of predefined integer types, or
2925          --  diagnose true ambiguity.
2926
2927          declare
2928             I     : Interp_Index;
2929             It    : Interp;
2930             Found : Entity_Id := Empty;
2931
2932          begin
2933             Get_First_Interp (R_Copy, I, It);
2934             while Present (It.Typ) loop
2935                if Is_Discrete_Type (It.Typ) then
2936                   if No (Found) then
2937                      Found := It.Typ;
2938                   else
2939                      if Scope (Found) = Standard_Standard then
2940                         null;
2941
2942                      elsif Scope (It.Typ) = Standard_Standard then
2943                         Found := It.Typ;
2944
2945                      else
2946                         --  Both of them are user-defined
2947
2948                         Error_Msg_N
2949                           ("ambiguous bounds in range of iteration", R_Copy);
2950                         Error_Msg_N ("\possible interpretations:", R_Copy);
2951                         Error_Msg_NE ("\\} ", R_Copy, Found);
2952                         Error_Msg_NE ("\\} ", R_Copy, It.Typ);
2953                         exit;
2954                      end if;
2955                   end if;
2956                end if;
2957
2958                Get_Next_Interp (I, It);
2959             end loop;
2960          end;
2961       end if;
2962
2963       --  Subtype mark in iteration scheme
2964
2965       if Is_Entity_Name (R_Copy)
2966         and then Is_Type (Entity (R_Copy))
2967       then
2968          null;
2969
2970       --  Expression in range, or Ada 2012 iterator
2971
2972       elsif Nkind (R_Copy) in N_Subexpr then
2973          Resolve (R_Copy);
2974       end if;
2975
2976       Expander_Mode_Restore;
2977       Full_Analysis := Save_Analysis;
2978    end Pre_Analyze_Range;
2979
2980 end Sem_Ch5;