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