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-2002 Free Software Foundation, Inc.          --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with 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_Util; use Exp_Util;
  33 with Freeze;   use Freeze;
  34 with Lib.Xref; use Lib.Xref;
  35 with Nlists;   use Nlists;
  36 with Opt;      use Opt;
  37 with Sem;      use Sem;
  38 with Sem_Case; use Sem_Case;
  39 with Sem_Ch3;  use Sem_Ch3;
  40 with Sem_Ch8;  use Sem_Ch8;
  41 with Sem_Disp; use Sem_Disp;
  42 with Sem_Eval; use Sem_Eval;
  43 with Sem_Res;  use Sem_Res;
  44 with Sem_Type; use Sem_Type;
  45 with Sem_Util; use Sem_Util;
  46 with Sem_Warn; use Sem_Warn;
  47 with Stand;    use Stand;
  48 with Sinfo;    use Sinfo;
  49 with Tbuild;   use Tbuild;
  50 with Uintp;    use Uintp;
  51
  52 package body Sem_Ch5 is
  53
  54    Unblocked_Exit_Count : Nat := 0;
  55    --  This variable is used when processing if statements or case
  56    --  statements, it counts the number of branches of the conditional
  57    --  that are not blocked by unconditional transfer instructions. At
  58    --  the end of processing, if the count is zero, it means that control
  59    --  cannot fall through the conditional statement. This is used for
  60    --  the generation of warning messages. This variable is recursively
  61    --  saved on entry to processing an if or case, and restored on exit.
  62
  63    -----------------------
  64    -- Local Subprograms --
  65    -----------------------
  66
  67    procedure Analyze_Iteration_Scheme (N : Node_Id);
  68
  69    ------------------------
  70    -- Analyze_Assignment --
  71    ------------------------
  72
  73    procedure Analyze_Assignment (N : Node_Id) is
  74       Lhs    : constant Node_Id := Name (N);
  75       Rhs    : constant Node_Id := Expression (N);
  76       T1, T2 : Entity_Id;
  77       Decl   : Node_Id;
  78
  79       procedure Diagnose_Non_Variable_Lhs (N : Node_Id);
  80       --  N is the node for the left hand side of an assignment, and it
  81       --  is not a variable. This routine issues an appropriate diagnostic.
  82
  83       procedure Set_Assignment_Type
  84         (Opnd      : Node_Id;
  85          Opnd_Type : in out Entity_Id);
  86       --  Opnd is either the Lhs or Rhs of the assignment, and Opnd_Type
  87       --  is the nominal subtype. This procedure is used to deal with cases
  88       --  where the nominal subtype must be replaced by the actual subtype.
  89
  90       -------------------------------
  91       -- Diagnose_Non_Variable_Lhs --
  92       -------------------------------
  93
  94       procedure Diagnose_Non_Variable_Lhs (N : Node_Id) is
  95       begin
  96          --  Not worth posting another error if left hand side already
  97          --  flagged as being illegal in some respect
  98
  99          if Error_Posted (N) then
 100             return;
 101
 102          --  Some special bad cases of entity names
 103
 104          elsif Is_Entity_Name (N) then
 105
 106             if Ekind (Entity (N)) = E_In_Parameter then
 107                Error_Msg_N
 108                  ("assignment to IN mode parameter not allowed", N);
 109                return;
 110
 111             --  Private declarations in a protected object are turned into
 112             --  constants when compiling a protected function.
 113
 114             elsif Present (Scope (Entity (N)))
 115               and then Is_Protected_Type (Scope (Entity (N)))
 116               and then
 117                 (Ekind (Current_Scope) = E_Function
 118                   or else
 119                  Ekind (Enclosing_Dynamic_Scope (Current_Scope)) = E_Function)
 120             then
 121                Error_Msg_N
 122                  ("protected function cannot modify protected object", N);
 123                return;
 124
 125             elsif Ekind (Entity (N)) = E_Loop_Parameter then
 126                Error_Msg_N
 127                  ("assignment to loop parameter not allowed", N);
 128                return;
 129
 130             end if;
 131
 132          --  For indexed components, or selected components, test prefix
 133
 134          elsif Nkind (N) = N_Indexed_Component
 135            or else Nkind (N) = N_Selected_Component
 136          then
 137             Diagnose_Non_Variable_Lhs (Prefix (N));
 138             return;
 139          end if;
 140
 141          --  If we fall through, we have no special message to issue!
 142
 143          Error_Msg_N ("left hand side of assignment must be a variable", N);
 144
 145       end Diagnose_Non_Variable_Lhs;
 146
 147       -------------------------
 148       -- Set_Assignment_Type --
 149       -------------------------
 150
 151       procedure Set_Assignment_Type
 152         (Opnd      : Node_Id;
 153          Opnd_Type : in out Entity_Id)
 154       is
 155       begin
 156          --  If the assignment operand is an in-out or out parameter, then we
 157          --  get the actual subtype (needed for the unconstrained case).
 158
 159          if Is_Entity_Name (Opnd)
 160            and then (Ekind (Entity (Opnd)) = E_Out_Parameter
 161                       or else Ekind (Entity (Opnd)) =
 162                            E_In_Out_Parameter
 163                       or else Ekind (Entity (Opnd)) =
 164                            E_Generic_In_Out_Parameter)
 165          then
 166             Opnd_Type := Get_Actual_Subtype (Opnd);
 167
 168          --  If assignment operand is a component reference, then we get the
 169          --  actual subtype of the component for the unconstrained case.
 170
 171          elsif Nkind (Opnd) = N_Selected_Component
 172            or else Nkind (Opnd) = N_Explicit_Dereference
 173          then
 174             Decl := Build_Actual_Subtype_Of_Component (Opnd_Type, Opnd);
 175
 176             if Present (Decl) then
 177                Insert_Action (N, Decl);
 178                Mark_Rewrite_Insertion (Decl);
 179                Analyze (Decl);
 180                Opnd_Type := Defining_Identifier (Decl);
 181                Set_Etype (Opnd, Opnd_Type);
 182                Freeze_Itype (Opnd_Type, N);
 183
 184             elsif Is_Constrained (Etype (Opnd)) then
 185                Opnd_Type := Etype (Opnd);
 186             end if;
 187
 188          --  For slice, use the constrained subtype created for the slice
 189
 190          elsif Nkind (Opnd) = N_Slice then
 191             Opnd_Type := Etype (Opnd);
 192          end if;
 193       end Set_Assignment_Type;
 194
 195    --  Start of processing for Analyze_Assignment
 196
 197    begin
 198       Analyze (Rhs);
 199       Analyze (Lhs);
 200       T1 := Etype (Lhs);
 201
 202       --  In the most general case, both Lhs and Rhs can be overloaded, and we
 203       --  must compute the intersection of the possible types on each side.
 204
 205       if Is_Overloaded (Lhs) then
 206          declare
 207             I  : Interp_Index;
 208             It : Interp;
 209
 210          begin
 211             T1 := Any_Type;
 212             Get_First_Interp (Lhs, I, It);
 213
 214             while Present (It.Typ) loop
 215                if Has_Compatible_Type (Rhs, It.Typ) then
 216
 217                   if T1 /= Any_Type then
 218
 219                      --  An explicit dereference is overloaded if the prefix
 220                      --  is. Try to remove the ambiguity on the prefix, the
 221                      --  error will be posted there if the ambiguity is real.
 222
 223                      if Nkind (Lhs) = N_Explicit_Dereference then
 224                         declare
 225                            PI    : Interp_Index;
 226                            PI1   : Interp_Index := 0;
 227                            PIt   : Interp;
 228                            Found : Boolean;
 229
 230                         begin
 231                            Found := False;
 232                            Get_First_Interp (Prefix (Lhs), PI, PIt);
 233
 234                            while Present (PIt.Typ) loop
 235                               if Has_Compatible_Type (Rhs,
 236                                 Designated_Type (PIt.Typ))
 237                               then
 238                                  if Found then
 239                                     PIt :=
 240                                       Disambiguate (Prefix (Lhs),
 241                                         PI1, PI, Any_Type);
 242
 243                                     if PIt = No_Interp then
 244                                        return;
 245                                     else
 246                                        Resolve (Prefix (Lhs), PIt.Typ);
 247                                     end if;
 248
 249                                     exit;
 250                                  else
 251                                     Found := True;
 252                                     PI1 := PI;
 253                                  end if;
 254                               end if;
 255
 256                               Get_Next_Interp (PI, PIt);
 257                            end loop;
 258                         end;
 259
 260                      else
 261                         Error_Msg_N
 262                           ("ambiguous left-hand side in assignment", Lhs);
 263                         exit;
 264                      end if;
 265                   else
 266                      T1 := It.Typ;
 267                   end if;
 268                end if;
 269
 270                Get_Next_Interp (I, It);
 271             end loop;
 272          end;
 273
 274          if T1 = Any_Type then
 275             Error_Msg_N
 276               ("no valid types for left-hand side for assignment", Lhs);
 277             return;
 278          end if;
 279       end if;
 280
 281       Resolve (Lhs, T1);
 282
 283       if not Is_Variable (Lhs) then
 284          Diagnose_Non_Variable_Lhs (Lhs);
 285          return;
 286
 287       elsif Is_Limited_Type (T1)
 288         and then not Assignment_OK (Lhs)
 289         and then not Assignment_OK (Original_Node (Lhs))
 290       then
 291          Error_Msg_N
 292            ("left hand of assignment must not be limited type", Lhs);
 293          return;
 294       end if;
 295
 296       --  Resolution may have updated the subtype, in case the left-hand
 297       --  side is a private protected component. Use the correct subtype
 298       --  to avoid scoping issues in the back-end.
 299
 300       T1 := Etype (Lhs);
 301       Set_Assignment_Type (Lhs, T1);
 302
 303       Resolve (Rhs, T1);
 304
 305       --  Remaining steps are skipped if Rhs was synatactically in error
 306
 307       if Rhs = Error then
 308          return;
 309       end if;
 310
 311       T2 := Etype (Rhs);
 312       Check_Unset_Reference (Rhs);
 313       Note_Possible_Modification (Lhs);
 314
 315       if Covers (T1, T2) then
 316          null;
 317       else
 318          Wrong_Type (Rhs, Etype (Lhs));
 319          return;
 320       end if;
 321
 322       Set_Assignment_Type (Rhs, T2);
 323
 324       if T1 = Any_Type or else T2 = Any_Type then
 325          return;
 326       end if;
 327
 328       if (Is_Class_Wide_Type (T2) or else Is_Dynamically_Tagged (Rhs))
 329         and then not Is_Class_Wide_Type (T1)
 330       then
 331          Error_Msg_N ("dynamically tagged expression not allowed!", Rhs);
 332
 333       elsif Is_Class_Wide_Type (T1)
 334         and then not Is_Class_Wide_Type (T2)
 335         and then not Is_Tag_Indeterminate (Rhs)
 336         and then not Is_Dynamically_Tagged (Rhs)
 337       then
 338          Error_Msg_N ("dynamically tagged expression required!", Rhs);
 339       end if;
 340
 341       --  Tag propagation is done only in semantics mode only. If expansion
 342       --  is on, the rhs tag indeterminate function call has been expanded
 343       --  and tag propagation would have happened too late, so the
 344       --  propagation take place in expand_call instead.
 345
 346       if not Expander_Active
 347         and then Is_Class_Wide_Type (T1)
 348         and then Is_Tag_Indeterminate (Rhs)
 349       then
 350          Propagate_Tag (Lhs, Rhs);
 351       end if;
 352
 353       if Is_Scalar_Type (T1) then
 354          Apply_Scalar_Range_Check (Rhs, Etype (Lhs));
 355
 356       elsif Is_Array_Type (T1) then
 357
 358          --  Assignment verifies that the length of the Lsh and Rhs are equal,
 359          --  but of course the indices do not have to match.
 360
 361          Apply_Length_Check (Rhs, Etype (Lhs));
 362
 363       else
 364          --  Discriminant checks are applied in the course of expansion.
 365          null;
 366       end if;
 367
 368       --  ??? a real accessibility check is needed when ???
 369
 370       --  Post warning for useless assignment
 371
 372       if Warn_On_Redundant_Constructs
 373
 374          --  We only warn for source constructs
 375
 376          and then Comes_From_Source (N)
 377
 378          --  Where the entity is the same on both sides
 379
 380          and then Is_Entity_Name (Lhs)
 381          and then Is_Entity_Name (Rhs)
 382          and then Entity (Lhs) = Entity (Rhs)
 383
 384          --  But exclude the case where the right side was an operation
 385          --  that got rewritten (e.g. JUNK + K, where K was known to be
 386          --  zero). We don't want to warn in such a case, since it is
 387          --  reasonable to write such expressions especially when K is
 388          --  defined symbolically in some other package.
 389
 390         and then Nkind (Original_Node (Rhs)) not in N_Op
 391       then
 392          Error_Msg_NE
 393            ("?useless assignment of & to itself", N, Entity (Lhs));
 394       end if;
 395    end Analyze_Assignment;
 396
 397    -----------------------------
 398    -- Analyze_Block_Statement --
 399    -----------------------------
 400
 401    procedure Analyze_Block_Statement (N : Node_Id) is
 402       Decls : constant List_Id := Declarations (N);
 403       Id    : constant Node_Id := Identifier (N);
 404       Ent   : Entity_Id;
 405
 406    begin
 407       --  If a label is present analyze it and mark it as referenced
 408
 409       if Present (Id) then
 410          Analyze (Id);
 411          Ent := Entity (Id);
 412          Set_Ekind (Ent, E_Block);
 413          Generate_Reference (Ent, N, ' ');
 414          Generate_Definition (Ent);
 415
 416          if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
 417             Set_Label_Construct (Parent (Ent), N);
 418          end if;
 419
 420       --  Otherwise create a label entity
 421
 422       else
 423          Ent := New_Internal_Entity (E_Block, Current_Scope, Sloc (N), 'B');
 424          Set_Identifier (N, New_Occurrence_Of (Ent, Sloc (N)));
 425       end if;
 426
 427       Set_Etype (Ent, Standard_Void_Type);
 428       Set_Block_Node (Ent, Identifier (N));
 429       New_Scope (Ent);
 430
 431       if Present (Decls) then
 432          Analyze_Declarations (Decls);
 433          Check_Completion;
 434       end if;
 435
 436       Analyze (Handled_Statement_Sequence (N));
 437       Process_End_Label (Handled_Statement_Sequence (N), 'e', Ent);
 438
 439       --  Analyze exception handlers if present. Note that the test for
 440       --  HSS being present is an error defence against previous errors.
 441
 442       if Present (Handled_Statement_Sequence (N))
 443         and then Present (Exception_Handlers (Handled_Statement_Sequence (N)))
 444       then
 445          declare
 446             S : Entity_Id := Scope (Ent);
 447
 448          begin
 449             --  Indicate that enclosing scopes contain a block with handlers.
 450             --  Only non-generic scopes need to be marked.
 451
 452             loop
 453                Set_Has_Nested_Block_With_Handler (S);
 454                exit when Is_Overloadable (S)
 455                  or else Ekind (S) = E_Package
 456                  or else Ekind (S) = E_Generic_Function
 457                  or else Ekind (S) = E_Generic_Package
 458                  or else Ekind (S) = E_Generic_Procedure;
 459                S := Scope (S);
 460             end loop;
 461          end;
 462       end if;
 463
 464       Check_References (Ent);
 465       End_Scope;
 466    end Analyze_Block_Statement;
 467
 468    ----------------------------
 469    -- Analyze_Case_Statement --
 470    ----------------------------
 471
 472    procedure Analyze_Case_Statement (N : Node_Id) is
 473
 474       Statements_Analyzed : Boolean := False;
 475       --  Set True if at least some statement sequences get analyzed.
 476       --  If False on exit, means we had a serious error that prevented
 477       --  full analysis of the case statement, and as a result it is not
 478       --  a good idea to output warning messages about unreachable code.
 479
 480       Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
 481       --  Recursively save value of this global, will be restored on exit
 482
 483       procedure Non_Static_Choice_Error (Choice : Node_Id);
 484       --  Error routine invoked by the generic instantiation below when
 485       --  the case statement has a non static choice.
 486
 487       procedure Process_Statements (Alternative : Node_Id);
 488       --  Analyzes all the statements associated to a case alternative.
 489       --  Needed by the generic instantiation below.
 490
 491       package Case_Choices_Processing is new
 492         Generic_Choices_Processing
 493           (Get_Alternatives          => Alternatives,
 494            Get_Choices               => Discrete_Choices,
 495            Process_Empty_Choice      => No_OP,
 496            Process_Non_Static_Choice => Non_Static_Choice_Error,
 497            Process_Associated_Node   => Process_Statements);
 498       use Case_Choices_Processing;
 499       --  Instantiation of the generic choice processing package.
 500
 501       -----------------------------
 502       -- Non_Static_Choice_Error --
 503       -----------------------------
 504
 505       procedure Non_Static_Choice_Error (Choice : Node_Id) is
 506       begin
 507          Error_Msg_N ("choice given in case statement is not static", Choice);
 508       end Non_Static_Choice_Error;
 509
 510       ------------------------
 511       -- Process_Statements --
 512       ------------------------
 513
 514       procedure Process_Statements (Alternative : Node_Id) is
 515       begin
 516          Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
 517          Statements_Analyzed := True;
 518          Analyze_Statements (Statements (Alternative));
 519       end Process_Statements;
 520
 521       --  Variables local to Analyze_Case_Statement.
 522
 523       Exp       : Node_Id;
 524       Exp_Type  : Entity_Id;
 525       Exp_Btype : Entity_Id;
 526
 527       Case_Table     : Choice_Table_Type (1 .. Number_Of_Choices (N));
 528       Last_Choice    : Nat;
 529       Dont_Care      : Boolean;
 530       Others_Present : Boolean;
 531
 532    --  Start of processing for Analyze_Case_Statement
 533
 534    begin
 535       Unblocked_Exit_Count := 0;
 536       Exp := Expression (N);
 537       Analyze_And_Resolve (Exp, Any_Discrete);
 538       Check_Unset_Reference (Exp);
 539       Exp_Type  := Etype (Exp);
 540       Exp_Btype := Base_Type (Exp_Type);
 541
 542       --  The expression must be of a discrete type which must be determinable
 543       --  independently of the context in which the expression occurs, but
 544       --  using the fact that the expression must be of a discrete type.
 545       --  Moreover, the type this expression must not be a character literal
 546       --  (which is always ambiguous) or, for Ada-83, a generic formal type.
 547
 548       --  If error already reported by Resolve, nothing more to do
 549
 550       if Exp_Btype = Any_Discrete
 551         or else Exp_Btype = Any_Type
 552       then
 553          return;
 554
 555       elsif Exp_Btype = Any_Character then
 556          Error_Msg_N
 557            ("character literal as case expression is ambiguous", Exp);
 558          return;
 559
 560       elsif Ada_83
 561         and then (Is_Generic_Type (Exp_Btype)
 562                     or else Is_Generic_Type (Root_Type (Exp_Btype)))
 563       then
 564          Error_Msg_N
 565            ("(Ada 83) case expression cannot be of a generic type", Exp);
 566          return;
 567       end if;
 568
 569       --  If the case expression is a formal object of mode in out,
 570       --  then treat it as having a nonstatic subtype by forcing
 571       --  use of the base type (which has to get passed to
 572       --  Check_Case_Choices below).  Also use base type when
 573       --  the case expression is parenthesized.
 574
 575       if Paren_Count (Exp) > 0
 576         or else (Is_Entity_Name (Exp)
 577                   and then Ekind (Entity (Exp)) = E_Generic_In_Out_Parameter)
 578       then
 579          Exp_Type := Exp_Btype;
 580       end if;
 581
 582       --  Call the instantiated Analyze_Choices which does the rest of the work
 583
 584       Analyze_Choices
 585         (N, Exp_Type, Case_Table, Last_Choice, Dont_Care, Others_Present);
 586
 587       if Exp_Type = Universal_Integer and then not Others_Present then
 588          Error_Msg_N ("case on universal integer requires OTHERS choice", Exp);
 589       end if;
 590
 591       --  If all our exits were blocked by unconditional transfers of control,
 592       --  then the entire CASE statement acts as an unconditional transfer of
 593       --  control, so treat it like one, and check unreachable code. Skip this
 594       --  test if we had serious errors preventing any statement analysis.
 595
 596       if Unblocked_Exit_Count = 0 and then Statements_Analyzed then
 597          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
 598          Check_Unreachable_Code (N);
 599       else
 600          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
 601       end if;
 602    end Analyze_Case_Statement;
 603
 604    ----------------------------
 605    -- Analyze_Exit_Statement --
 606    ----------------------------
 607
 608    --  If the exit includes a name, it must be the name of a currently open
 609    --  loop. Otherwise there must be an innermost open loop on the stack,
 610    --  to which the statement implicitly refers.
 611
 612    procedure Analyze_Exit_Statement (N : Node_Id) is
 613       Target   : constant Node_Id := Name (N);
 614       Cond     : constant Node_Id := Condition (N);
 615       Scope_Id : Entity_Id;
 616       U_Name   : Entity_Id;
 617       Kind     : Entity_Kind;
 618
 619    begin
 620       if No (Cond) then
 621          Check_Unreachable_Code (N);
 622       end if;
 623
 624       if Present (Target) then
 625          Analyze (Target);
 626          U_Name := Entity (Target);
 627
 628          if not In_Open_Scopes (U_Name) or else Ekind (U_Name) /= E_Loop then
 629             Error_Msg_N ("invalid loop name in exit statement", N);
 630             return;
 631          else
 632             Set_Has_Exit (U_Name);
 633          end if;
 634
 635       else
 636          U_Name := Empty;
 637       end if;
 638
 639       for J in reverse 0 .. Scope_Stack.Last loop
 640          Scope_Id := Scope_Stack.Table (J).Entity;
 641          Kind := Ekind (Scope_Id);
 642
 643          if Kind = E_Loop
 644            and then (No (Target) or else Scope_Id = U_Name) then
 645             Set_Has_Exit (Scope_Id);
 646             exit;
 647
 648          elsif Kind = E_Block or else Kind = E_Loop then
 649             null;
 650
 651          else
 652             Error_Msg_N
 653               ("cannot exit from program unit or accept statement", N);
 654             exit;
 655          end if;
 656       end loop;
 657
 658       --  Verify that if present the condition is a Boolean expression.
 659
 660       if Present (Cond) then
 661          Analyze_And_Resolve (Cond, Any_Boolean);
 662          Check_Unset_Reference (Cond);
 663       end if;
 664    end Analyze_Exit_Statement;
 665
 666    ----------------------------
 667    -- Analyze_Goto_Statement --
 668    ----------------------------
 669
 670    procedure Analyze_Goto_Statement (N : Node_Id) is
 671       Label       : constant Node_Id := Name (N);
 672       Scope_Id    : Entity_Id;
 673       Label_Scope : Entity_Id;
 674
 675    begin
 676       Check_Unreachable_Code (N);
 677
 678       Analyze (Label);
 679
 680       if Entity (Label) = Any_Id then
 681          return;
 682
 683       elsif Ekind (Entity (Label)) /= E_Label then
 684          Error_Msg_N ("target of goto statement must be a label", Label);
 685          return;
 686
 687       elsif not Reachable (Entity (Label)) then
 688          Error_Msg_N ("target of goto statement is not reachable", Label);
 689          return;
 690       end if;
 691
 692       Label_Scope := Enclosing_Scope (Entity (Label));
 693
 694       for J in reverse 0 .. Scope_Stack.Last loop
 695          Scope_Id := Scope_Stack.Table (J).Entity;
 696
 697          if Label_Scope = Scope_Id
 698            or else (Ekind (Scope_Id) /= E_Block
 699                      and then Ekind (Scope_Id) /= E_Loop)
 700          then
 701             if Scope_Id /= Label_Scope then
 702                Error_Msg_N
 703                  ("cannot exit from program unit or accept statement", N);
 704             end if;
 705
 706             return;
 707          end if;
 708       end loop;
 709
 710       raise Program_Error;
 711
 712    end Analyze_Goto_Statement;
 713
 714    --------------------------
 715    -- Analyze_If_Statement --
 716    --------------------------
 717
 718    --  A special complication arises in the analysis of if statements.
 719    --  The expander has circuitry to completely deleted code that it
 720    --  can tell will not be executed (as a result of compile time known
 721    --  conditions). In the analyzer, we ensure that code that will be
 722    --  deleted in this manner is analyzed but not expanded. This is
 723    --  obviously more efficient, but more significantly, difficulties
 724    --  arise if code is expanded and then eliminated (e.g. exception
 725    --  table entries disappear).
 726
 727    procedure Analyze_If_Statement (N : Node_Id) is
 728       E : Node_Id;
 729
 730       Save_Unblocked_Exit_Count : constant Nat := Unblocked_Exit_Count;
 731       --  Recursively save value of this global, will be restored on exit
 732
 733       Del : Boolean := False;
 734       --  This flag gets set True if a True condition has been found,
 735       --  which means that remaining ELSE/ELSIF parts are deleted.
 736
 737       procedure Analyze_Cond_Then (Cnode : Node_Id);
 738       --  This is applied to either the N_If_Statement node itself or
 739       --  to an N_Elsif_Part node. It deals with analyzing the condition
 740       --  and the THEN statements associated with it.
 741
 742       procedure Analyze_Cond_Then (Cnode : Node_Id) is
 743          Cond : constant Node_Id := Condition (Cnode);
 744          Tstm : constant List_Id := Then_Statements (Cnode);
 745
 746       begin
 747          Unblocked_Exit_Count := Unblocked_Exit_Count + 1;
 748          Analyze_And_Resolve (Cond, Any_Boolean);
 749          Check_Unset_Reference (Cond);
 750
 751          --  If already deleting, then just analyze then statements
 752
 753          if Del then
 754             Analyze_Statements (Tstm);
 755
 756          --  Compile time known value, not deleting yet
 757
 758          elsif Compile_Time_Known_Value (Cond) then
 759
 760             --  If condition is True, then analyze the THEN statements
 761             --  and set no expansion for ELSE and ELSIF parts.
 762
 763             if Is_True (Expr_Value (Cond)) then
 764                Analyze_Statements (Tstm);
 765                Del := True;
 766                Expander_Mode_Save_And_Set (False);
 767
 768             --  If condition is False, analyze THEN with expansion off
 769
 770             else -- Is_False (Expr_Value (Cond))
 771                Expander_Mode_Save_And_Set (False);
 772                Analyze_Statements (Tstm);
 773                Expander_Mode_Restore;
 774             end if;
 775
 776          --  Not known at compile time, not deleting, normal analysis
 777
 778          else
 779             Analyze_Statements (Tstm);
 780          end if;
 781       end Analyze_Cond_Then;
 782
 783    --  Start of Analyze_If_Statement
 784
 785    begin
 786       --  Initialize exit count for else statements. If there is no else
 787       --  part, this count will stay non-zero reflecting the fact that the
 788       --  uncovered else case is an unblocked exit.
 789
 790       Unblocked_Exit_Count := 1;
 791       Analyze_Cond_Then (N);
 792
 793       --  Now to analyze the elsif parts if any are present
 794
 795       if Present (Elsif_Parts (N)) then
 796          E := First (Elsif_Parts (N));
 797          while Present (E) loop
 798             Analyze_Cond_Then (E);
 799             Next (E);
 800          end loop;
 801       end if;
 802
 803       if Present (Else_Statements (N)) then
 804          Analyze_Statements (Else_Statements (N));
 805       end if;
 806
 807       --  If all our exits were blocked by unconditional transfers of control,
 808       --  then the entire IF statement acts as an unconditional transfer of
 809       --  control, so treat it like one, and check unreachable code.
 810
 811       if Unblocked_Exit_Count = 0 then
 812          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
 813          Check_Unreachable_Code (N);
 814       else
 815          Unblocked_Exit_Count := Save_Unblocked_Exit_Count;
 816       end if;
 817
 818       if Del then
 819          Expander_Mode_Restore;
 820       end if;
 821
 822    end Analyze_If_Statement;
 823
 824    ----------------------------------------
 825    -- Analyze_Implicit_Label_Declaration --
 826    ----------------------------------------
 827
 828    --  An implicit label declaration is generated in the innermost
 829    --  enclosing declarative part. This is done for labels as well as
 830    --  block and loop names.
 831
 832    --  Note: any changes in this routine may need to be reflected in
 833    --  Analyze_Label_Entity.
 834
 835    procedure Analyze_Implicit_Label_Declaration (N : Node_Id) is
 836       Id : Node_Id := Defining_Identifier (N);
 837
 838    begin
 839       Enter_Name (Id);
 840       Set_Ekind           (Id, E_Label);
 841       Set_Etype           (Id, Standard_Void_Type);
 842       Set_Enclosing_Scope (Id, Current_Scope);
 843    end Analyze_Implicit_Label_Declaration;
 844
 845    ------------------------------
 846    -- Analyze_Iteration_Scheme --
 847    ------------------------------
 848
 849    procedure Analyze_Iteration_Scheme (N : Node_Id) is
 850    begin
 851       --  For an infinite loop, there is no iteration scheme
 852
 853       if No (N) then
 854          return;
 855
 856       else
 857          declare
 858             Cond : constant Node_Id := Condition (N);
 859
 860          begin
 861             --  For WHILE loop, verify that the condition is a Boolean
 862             --  expression and resolve and check it.
 863
 864             if Present (Cond) then
 865                Analyze_And_Resolve (Cond, Any_Boolean);
 866                Check_Unset_Reference (Cond);
 867
 868             --  Else we have a FOR loop
 869
 870             else
 871                declare
 872                   LP : constant Node_Id   := Loop_Parameter_Specification (N);
 873                   Id : constant Entity_Id := Defining_Identifier (LP);
 874                   DS : constant Node_Id   := Discrete_Subtype_Definition (LP);
 875                   F  : List_Id;
 876
 877                begin
 878                   Enter_Name (Id);
 879
 880                   --  We always consider the loop variable to be referenced,
 881                   --  since the loop may be used just for counting purposes.
 882
 883                   Generate_Reference (Id, N, ' ');
 884
 885                   --  Check for case of loop variable hiding a local
 886                   --  variable (used later on to give a nice warning
 887                   --  if the hidden variable is never assigned).
 888
 889                   declare
 890                      H : constant Entity_Id := Homonym (Id);
 891
 892                   begin
 893                      if Present (H)
 894                        and then Enclosing_Dynamic_Scope (H) =
 895                                 Enclosing_Dynamic_Scope (Id)
 896                        and then Ekind (H) = E_Variable
 897                        and then Is_Discrete_Type (Etype (H))
 898                      then
 899                         Set_Hiding_Loop_Variable (H, Id);
 900                      end if;
 901                   end;
 902
 903                   --  Now analyze the subtype definition
 904
 905                   Analyze (DS);
 906
 907                   if DS = Error then
 908                      return;
 909                   end if;
 910
 911                   --  The subtype indication may denote the completion
 912                   --  of an incomplete type declaration.
 913
 914                   if Is_Entity_Name (DS)
 915                     and then Present (Entity (DS))
 916                     and then Is_Type (Entity (DS))
 917                     and then Ekind (Entity (DS)) = E_Incomplete_Type
 918                   then
 919                      Set_Entity (DS, Get_Full_View (Entity (DS)));
 920                      Set_Etype  (DS, Entity (DS));
 921                   end if;
 922
 923                   if not Is_Discrete_Type (Etype (DS)) then
 924                      Wrong_Type (DS, Any_Discrete);
 925                      Set_Etype (DS, Any_Type);
 926                   end if;
 927
 928                   Make_Index (DS, LP);
 929
 930                   Set_Ekind          (Id, E_Loop_Parameter);
 931                   Set_Etype          (Id, Etype (DS));
 932                   Set_Is_Known_Valid (Id, True);
 933
 934                   --  The loop is not a declarative part, so the only entity
 935                   --  declared "within" must be frozen explicitly. Since the
 936                   --  type of this entity has already been frozen, this cannot
 937                   --  generate any freezing actions.
 938
 939                   F := Freeze_Entity (Id, Sloc (LP));
 940                   pragma Assert (F = No_List);
 941
 942                   --  Check for null or possibly null range and issue warning.
 943                   --  We suppress such messages in generic templates and
 944                   --  instances, because in practice they tend to be dubious
 945                   --  in these cases.
 946
 947                   if Nkind (DS) = N_Range
 948                     and then Comes_From_Source (N)
 949                     and then not Inside_A_Generic
 950                     and then not In_Instance
 951                   then
 952                      declare
 953                         L : constant Node_Id := Low_Bound  (DS);
 954                         H : constant Node_Id := High_Bound (DS);
 955
 956                         Llo : Uint;
 957                         Lhi : Uint;
 958                         LOK : Boolean;
 959                         Hlo : Uint;
 960                         Hhi : Uint;
 961                         HOK : Boolean;
 962
 963                      begin
 964                         Determine_Range (L, LOK, Llo, Lhi);
 965                         Determine_Range (H, HOK, Hlo, Hhi);
 966
 967                         --  If range of loop is null, issue warning
 968
 969                         if (LOK and HOK) and then Llo > Hhi then
 970                            Error_Msg_N
 971                              ("?loop range is null, loop will not execute",
 972                               DS);
 973
 974                         --  The other case for a warning is a reverse loop
 975                         --  where the upper bound is the integer literal
 976                         --  zero or one, and the lower bound can be positive.
 977
 978                         elsif Reverse_Present (LP)
 979                           and then Nkind (H) = N_Integer_Literal
 980                           and then (Intval (H) = Uint_0
 981                                       or else
 982                                     Intval (H) = Uint_1)
 983                           and then Lhi > Hhi
 984                         then
 985                            Warn_On_Instance := True;
 986                            Error_Msg_N ("?loop range may be null", DS);
 987                            Warn_On_Instance := False;
 988                         end if;
 989                      end;
 990                   end if;
 991                end;
 992             end if;
 993          end;
 994       end if;
 995    end Analyze_Iteration_Scheme;
 996
 997    -------------------
 998    -- Analyze_Label --
 999    -------------------
1000
1001    --  Important note: normally this routine is called from Analyze_Statements
1002    --  which does a prescan, to make sure that the Reachable flags are set on
1003    --  all labels before encountering a possible goto to one of these labels.
1004    --  If expanded code analyzes labels via the normal Sem path, then it must
1005    --  ensure that Reachable is set early enough to avoid problems in the case
1006    --  of a forward goto.
1007
1008    procedure Analyze_Label (N : Node_Id) is
1009       Lab : Entity_Id;
1010
1011    begin
1012       Analyze (Identifier (N));
1013       Lab := Entity (Identifier (N));
1014
1015       --  If we found a label mark it as reachable.
1016
1017       if Ekind (Lab) = E_Label then
1018          Generate_Definition (Lab);
1019          Set_Reachable (Lab);
1020
1021          if Nkind (Parent (Lab)) = N_Implicit_Label_Declaration then
1022             Set_Label_Construct (Parent (Lab), N);
1023          end if;
1024
1025       --  If we failed to find a label, it means the implicit declaration
1026       --  of the label was hidden.  A for-loop parameter can do this to a
1027       --  label with the same name inside the loop, since the implicit label
1028       --  declaration is in the innermost enclosing body or block statement.
1029
1030       else
1031          Error_Msg_Sloc := Sloc (Lab);
1032          Error_Msg_N
1033            ("implicit label declaration for & is hidden#",
1034             Identifier (N));
1035       end if;
1036    end Analyze_Label;
1037
1038    --------------------------
1039    -- Analyze_Label_Entity --
1040    --------------------------
1041
1042    procedure Analyze_Label_Entity (E : Entity_Id) is
1043    begin
1044       Set_Ekind           (E, E_Label);
1045       Set_Etype           (E, Standard_Void_Type);
1046       Set_Enclosing_Scope (E, Current_Scope);
1047       Set_Reachable       (E, True);
1048    end Analyze_Label_Entity;
1049
1050    ----------------------------
1051    -- Analyze_Loop_Statement --
1052    ----------------------------
1053
1054    procedure Analyze_Loop_Statement (N : Node_Id) is
1055       Id  : constant Node_Id := Identifier (N);
1056       Ent : Entity_Id;
1057
1058    begin
1059       if Present (Id) then
1060
1061          --  Make name visible, e.g. for use in exit statements. Loop
1062          --  labels are always considered to be referenced.
1063
1064          Analyze (Id);
1065          Ent := Entity (Id);
1066          Generate_Reference  (Ent, N, ' ');
1067          Generate_Definition (Ent);
1068
1069          --  If we found a label, mark its type. If not, ignore it, since it
1070          --  means we have a conflicting declaration, which would already have
1071          --  been diagnosed at declaration time. Set Label_Construct of the
1072          --  implicit label declaration, which is not created by the parser
1073          --  for generic units.
1074
1075          if Ekind (Ent) = E_Label then
1076             Set_Ekind (Ent, E_Loop);
1077
1078             if Nkind (Parent (Ent)) = N_Implicit_Label_Declaration then
1079                Set_Label_Construct (Parent (Ent), N);
1080             end if;
1081          end if;
1082
1083       --  Case of no identifier present
1084
1085       else
1086          Ent := New_Internal_Entity (E_Loop, Current_Scope, Sloc (N), 'L');
1087          Set_Etype (Ent,  Standard_Void_Type);
1088          Set_Parent (Ent, N);
1089       end if;
1090
1091       New_Scope (Ent);
1092       Analyze_Iteration_Scheme (Iteration_Scheme (N));
1093       Analyze_Statements (Statements (N));
1094       Process_End_Label (N, 'e', Ent);
1095       End_Scope;
1096    end Analyze_Loop_Statement;
1097
1098    ----------------------------
1099    -- Analyze_Null_Statement --
1100    ----------------------------
1101
1102    --  Note: the semantics of the null statement is implemented by a single
1103    --  null statement, too bad everything isn't as simple as this!
1104
1105    procedure Analyze_Null_Statement (N : Node_Id) is
1106       pragma Warnings (Off, N);
1107
1108    begin
1109       null;
1110    end Analyze_Null_Statement;
1111
1112    ------------------------
1113    -- Analyze_Statements --
1114    ------------------------
1115
1116    procedure Analyze_Statements (L : List_Id) is
1117       S : Node_Id;
1118
1119    begin
1120       --  The labels declared in the statement list are reachable from
1121       --  statements in the list. We do this as a prepass so that any
1122       --  goto statement will be properly flagged if its target is not
1123       --  reachable. This is not required, but is nice behavior!
1124
1125       S := First (L);
1126
1127       while Present (S) loop
1128          if Nkind (S) = N_Label then
1129             Analyze_Label (S);
1130          end if;
1131
1132          Next (S);
1133       end loop;
1134
1135       --  Perform semantic analysis on all statements
1136
1137       S := First (L);
1138
1139       while Present (S) loop
1140
1141          if Nkind (S) /= N_Label then
1142             Analyze (S);
1143          end if;
1144
1145          Next (S);
1146       end loop;
1147
1148       --  Make labels unreachable. Visibility is not sufficient, because
1149       --  labels in one if-branch for example are not reachable from the
1150       --  other branch, even though their declarations are in the enclosing
1151       --  declarative part.
1152
1153       S := First (L);
1154
1155       while Present (S) loop
1156          if Nkind (S) = N_Label then
1157             Set_Reachable (Entity (Identifier (S)), False);
1158          end if;
1159
1160          Next (S);
1161       end loop;
1162    end Analyze_Statements;
1163
1164    ----------------------------
1165    -- Check_Unreachable_Code --
1166    ----------------------------
1167
1168    procedure Check_Unreachable_Code (N : Node_Id) is
1169       Error_Loc : Source_Ptr;
1170       P         : Node_Id;
1171
1172    begin
1173       if Is_List_Member (N)
1174         and then Comes_From_Source (N)
1175       then
1176          declare
1177             Nxt : Node_Id;
1178
1179          begin
1180             Nxt := Original_Node (Next (N));
1181
1182             if Present (Nxt)
1183               and then Comes_From_Source (Nxt)
1184               and then Is_Statement (Nxt)
1185             then
1186                --  Special very annoying exception. If we have a return that
1187                --  follows a raise, then we allow it without a warning, since
1188                --  the Ada RM annoyingly requires a useless return here!
1189
1190                if Nkind (Original_Node (N)) /= N_Raise_Statement
1191                  or else Nkind (Nxt) /= N_Return_Statement
1192                then
1193                   --  The rather strange shenanigans with the warning message
1194                   --  here reflects the fact that Kill_Dead_Code is very good
1195                   --  at removing warnings in deleted code, and this is one
1196                   --  warning we would prefer NOT to have removed :-)
1197
1198                   Error_Loc := Sloc (Nxt);
1199
1200                   --  If we have unreachable code, analyze and remove the
1201                   --  unreachable code, since it is useless and we don't
1202                   --  want to generate junk warnings.
1203
1204                   --  We skip this step if we are not in code generation mode.
1205                   --  This is the one case where we remove dead code in the
1206                   --  semantics as opposed to the expander, and we do not want
1207                   --  to remove code if we are not in code generation mode,
1208                   --  since this messes up the ASIS trees.
1209
1210                   --  Note that one might react by moving the whole circuit to
1211                   --  exp_ch5, but then we lose the warning in -gnatc mode.
1212
1213                   if Operating_Mode = Generate_Code then
1214                      loop
1215                         Nxt := Next (N);
1216                         exit when No (Nxt) or else not Is_Statement (Nxt);
1217                         Analyze (Nxt);
1218                         Remove (Nxt);
1219                         Kill_Dead_Code (Nxt);
1220                      end loop;
1221                   end if;
1222
1223                   --  Now issue the warning
1224
1225                   Error_Msg ("?unreachable code", Error_Loc);
1226                end if;
1227
1228             --  If the unconditional transfer of control instruction is
1229             --  the last statement of a sequence, then see if our parent
1230             --  is an IF statement, and if so adjust the unblocked exit
1231             --  count of the if statement to reflect the fact that this
1232             --  branch of the if is indeed blocked by a transfer of control.
1233
1234             else
1235                P := Parent (N);
1236
1237                if Nkind (P) = N_If_Statement then
1238                   null;
1239
1240                elsif Nkind (P) = N_Elsif_Part then
1241                   P := Parent (P);
1242                   pragma Assert (Nkind (P) = N_If_Statement);
1243
1244                elsif Nkind (P) = N_Case_Statement_Alternative then
1245                   P := Parent (P);
1246                   pragma Assert (Nkind (P) = N_Case_Statement);
1247
1248                else
1249                   return;
1250                end if;
1251
1252                Unblocked_Exit_Count := Unblocked_Exit_Count - 1;
1253             end if;
1254          end;
1255       end if;
1256    end Check_Unreachable_Code;
1257
1258 end Sem_Ch5;