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