gcc/ada/sem_ch9.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                              S E M _ C H 9                               --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2004, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  20 -- MA 02111-1307, USA.                                                      --
  21 --                                                                          --
  22 -- GNAT was originally developed  by the GNAT team at  New York University. --
  23 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  24 --                                                                          --
  25 ------------------------------------------------------------------------------
  26
  27 with Atree;    use Atree;
  28 with Checks;   use Checks;
  29 with Einfo;    use Einfo;
  30 with Errout;   use Errout;
  31 with Exp_Ch9;
  32 with Elists;   use Elists;
  33 with Itypes;   use Itypes;
  34 with Lib.Xref; use Lib.Xref;
  35 with Nlists;   use Nlists;
  36 with Nmake;    use Nmake;
  37 with Opt;      use Opt;
  38 with Restrict; use Restrict;
  39 with Rident;   use Rident;
  40 with Rtsfind;  use Rtsfind;
  41 with Sem;      use Sem;
  42 with Sem_Ch3;  use Sem_Ch3;
  43 with Sem_Ch5;  use Sem_Ch5;
  44 with Sem_Ch6;  use Sem_Ch6;
  45 with Sem_Ch8;  use Sem_Ch8;
  46 with Sem_Eval; use Sem_Eval;
  47 with Sem_Res;  use Sem_Res;
  48 with Sem_Type; use Sem_Type;
  49 with Sem_Util; use Sem_Util;
  50 with Sem_Warn; use Sem_Warn;
  51 with Snames;   use Snames;
  52 with Stand;    use Stand;
  53 with Sinfo;    use Sinfo;
  54 with Style;
  55 with Tbuild;   use Tbuild;
  56 with Uintp;    use Uintp;
  57
  58 package body Sem_Ch9 is
  59
  60    -----------------------
  61    -- Local Subprograms --
  62    -----------------------
  63
  64    procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions);
  65    --  Given either a protected definition or a task definition in D, check
  66    --  the corresponding restriction parameter identifier R, and if it is set,
  67    --  count the entries (checking the static requirement), and compare with
  68    --  the given maximum.
  69
  70    function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id;
  71    --  Find entity in corresponding task or protected declaration. Use full
  72    --  view if first declaration was for an incomplete type.
  73
  74    procedure Install_Declarations (Spec : Entity_Id);
  75    --  Utility to make visible in corresponding body the entities defined
  76    --  in task, protected type declaration, or entry declaration.
  77
  78    -----------------------------
  79    -- Analyze_Abort_Statement --
  80    -----------------------------
  81
  82    procedure Analyze_Abort_Statement (N : Node_Id) is
  83       T_Name : Node_Id;
  84
  85    begin
  86       Tasking_Used := True;
  87       T_Name := First (Names (N));
  88       while Present (T_Name) loop
  89          Analyze (T_Name);
  90
  91          if not Is_Task_Type (Etype (T_Name)) then
  92             Error_Msg_N ("expect task name for ABORT", T_Name);
  93             return;
  94          else
  95             Resolve (T_Name);
  96          end if;
  97
  98          Next (T_Name);
  99       end loop;
 100
 101       Check_Restriction (No_Abort_Statements, N);
 102       Check_Potentially_Blocking_Operation (N);
 103    end Analyze_Abort_Statement;
 104
 105    --------------------------------
 106    -- Analyze_Accept_Alternative --
 107    --------------------------------
 108
 109    procedure Analyze_Accept_Alternative (N : Node_Id) is
 110    begin
 111       Tasking_Used := True;
 112
 113       if Present (Pragmas_Before (N)) then
 114          Analyze_List (Pragmas_Before (N));
 115       end if;
 116
 117       if Present (Condition (N)) then
 118          Analyze_And_Resolve (Condition (N), Any_Boolean);
 119       end if;
 120
 121       Analyze (Accept_Statement (N));
 122
 123       if Is_Non_Empty_List (Statements (N)) then
 124          Analyze_Statements (Statements (N));
 125       end if;
 126    end Analyze_Accept_Alternative;
 127
 128    ------------------------------
 129    -- Analyze_Accept_Statement --
 130    ------------------------------
 131
 132    procedure Analyze_Accept_Statement (N : Node_Id) is
 133       Nam       : constant Entity_Id := Entry_Direct_Name (N);
 134       Formals   : constant List_Id   := Parameter_Specifications (N);
 135       Index     : constant Node_Id   := Entry_Index (N);
 136       Stats     : constant Node_Id   := Handled_Statement_Sequence (N);
 137       Accept_Id : Entity_Id;
 138       Entry_Nam : Entity_Id;
 139       E         : Entity_Id;
 140       Kind      : Entity_Kind;
 141       Task_Nam  : Entity_Id;
 142
 143       -----------------------
 144       -- Actual_Index_Type --
 145       -----------------------
 146
 147       function Actual_Index_Type (E : Entity_Id) return Entity_Id;
 148       --  If the bounds of an entry family depend on task discriminants,
 149       --  create a new index type where a discriminant is replaced by the
 150       --  local variable that renames it in the task body.
 151
 152       function Actual_Index_Type (E : Entity_Id) return Entity_Id is
 153          Typ   : constant Entity_Id := Entry_Index_Type (E);
 154          Lo    : constant Node_Id   := Type_Low_Bound  (Typ);
 155          Hi    : constant Node_Id   := Type_High_Bound (Typ);
 156          New_T : Entity_Id;
 157
 158          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id;
 159          --  If bound is discriminant reference, replace with corresponding
 160          --  local variable of the same name.
 161
 162          -----------------------------
 163          -- Actual_Discriminant_Ref --
 164          -----------------------------
 165
 166          function Actual_Discriminant_Ref (Bound : Node_Id) return Node_Id is
 167             Typ : constant Entity_Id := Etype (Bound);
 168             Ref : Node_Id;
 169
 170          begin
 171             if not Is_Entity_Name (Bound)
 172               or else Ekind (Entity (Bound)) /= E_Discriminant
 173             then
 174                return Bound;
 175
 176             else
 177                Ref := Make_Identifier (Sloc (N), Chars (Entity (Bound)));
 178                Analyze (Ref);
 179                Resolve (Ref, Typ);
 180                return Ref;
 181             end if;
 182          end Actual_Discriminant_Ref;
 183
 184       --  Start of processing for Actual_Index_Type
 185
 186       begin
 187          if not Has_Discriminants (Task_Nam)
 188            or else (not Is_Entity_Name (Lo)
 189                      and then not Is_Entity_Name (Hi))
 190          then
 191             return Entry_Index_Type (E);
 192          else
 193             New_T := Create_Itype (Ekind (Typ), N);
 194             Set_Etype        (New_T, Base_Type (Typ));
 195             Set_Size_Info    (New_T, Typ);
 196             Set_RM_Size      (New_T, RM_Size (Typ));
 197             Set_Scalar_Range (New_T,
 198               Make_Range (Sloc (N),
 199                 Low_Bound  => Actual_Discriminant_Ref (Lo),
 200                 High_Bound => Actual_Discriminant_Ref (Hi)));
 201
 202             return New_T;
 203          end if;
 204       end Actual_Index_Type;
 205
 206    --  Start of processing for Analyze_Accept_Statement
 207
 208    begin
 209       Tasking_Used := True;
 210
 211       --  Entry name is initialized to Any_Id. It should get reset to the
 212       --  matching entry entity. An error is signalled if it is not reset.
 213
 214       Entry_Nam := Any_Id;
 215
 216       for J in reverse 0 .. Scope_Stack.Last loop
 217          Task_Nam := Scope_Stack.Table (J).Entity;
 218          exit when Ekind (Etype (Task_Nam)) = E_Task_Type;
 219          Kind :=  Ekind (Task_Nam);
 220
 221          if Kind /= E_Block and then Kind /= E_Loop
 222            and then not Is_Entry (Task_Nam)
 223          then
 224             Error_Msg_N ("enclosing body of accept must be a task", N);
 225             return;
 226          end if;
 227       end loop;
 228
 229       if Ekind (Etype (Task_Nam)) /= E_Task_Type then
 230          Error_Msg_N ("invalid context for accept statement",  N);
 231          return;
 232       end if;
 233
 234       --  In order to process the parameters, we create a defining
 235       --  identifier that can be used as the name of the scope. The
 236       --  name of the accept statement itself is not a defining identifier,
 237       --  and we cannot use its name directly because the task may have
 238       --  any number of accept statements for the same entry.
 239
 240       if Present (Index) then
 241          Accept_Id := New_Internal_Entity
 242            (E_Entry_Family, Current_Scope, Sloc (N), 'E');
 243       else
 244          Accept_Id := New_Internal_Entity
 245            (E_Entry, Current_Scope, Sloc (N), 'E');
 246       end if;
 247
 248       Set_Etype          (Accept_Id, Standard_Void_Type);
 249       Set_Accept_Address (Accept_Id, New_Elmt_List);
 250
 251       if Present (Formals) then
 252          New_Scope (Accept_Id);
 253          Process_Formals (Formals, N);
 254          Create_Extra_Formals (Accept_Id);
 255          End_Scope;
 256       end if;
 257
 258       --  We set the default expressions processed flag because we don't
 259       --  need default expression functions. This is really more like a
 260       --  body entity than a spec entity anyway.
 261
 262       Set_Default_Expressions_Processed (Accept_Id);
 263
 264       E := First_Entity (Etype (Task_Nam));
 265       while Present (E) loop
 266          if Chars (E) = Chars (Nam)
 267            and then (Ekind (E) = Ekind (Accept_Id))
 268            and then Type_Conformant (Accept_Id, E)
 269          then
 270             Entry_Nam := E;
 271             exit;
 272          end if;
 273
 274          Next_Entity (E);
 275       end loop;
 276
 277       if Entry_Nam = Any_Id then
 278          Error_Msg_N ("no entry declaration matches accept statement",  N);
 279          return;
 280       else
 281          Set_Entity (Nam, Entry_Nam);
 282          Generate_Reference (Entry_Nam, Nam, 'b', Set_Ref => False);
 283          Style.Check_Identifier (Nam, Entry_Nam);
 284       end if;
 285
 286       --  Verify that the entry is not hidden by a procedure declared in
 287       --  the current block (pathological but possible).
 288
 289       if Current_Scope /= Task_Nam then
 290          declare
 291             E1 : Entity_Id;
 292
 293          begin
 294             E1 := First_Entity (Current_Scope);
 295
 296             while Present (E1) loop
 297
 298                if Ekind (E1) = E_Procedure
 299                  and then Chars (E1) = Chars (Entry_Nam)
 300                  and then Type_Conformant (E1, Entry_Nam)
 301                then
 302                   Error_Msg_N ("entry name is not visible", N);
 303                end if;
 304
 305                Next_Entity (E1);
 306             end loop;
 307          end;
 308       end if;
 309
 310       Set_Convention (Accept_Id, Convention (Entry_Nam));
 311       Check_Fully_Conformant (Accept_Id, Entry_Nam, N);
 312
 313       for J in reverse 0 .. Scope_Stack.Last loop
 314          exit when Task_Nam = Scope_Stack.Table (J).Entity;
 315
 316          if Entry_Nam = Scope_Stack.Table (J).Entity then
 317             Error_Msg_N ("duplicate accept statement for same entry", N);
 318          end if;
 319
 320       end loop;
 321
 322       declare
 323          P : Node_Id := N;
 324       begin
 325          loop
 326             P := Parent (P);
 327             case Nkind (P) is
 328                when N_Task_Body | N_Compilation_Unit =>
 329                   exit;
 330                when N_Asynchronous_Select =>
 331                   Error_Msg_N ("accept statements are not allowed within" &
 332                                " an asynchronous select inner" &
 333                                " to the enclosing task body", N);
 334                   exit;
 335                when others =>
 336                   null;
 337             end case;
 338          end loop;
 339       end;
 340
 341       if Ekind (E) = E_Entry_Family then
 342          if No (Index) then
 343             Error_Msg_N ("missing entry index in accept for entry family", N);
 344          else
 345             Analyze_And_Resolve (Index, Entry_Index_Type (E));
 346             Apply_Range_Check (Index, Actual_Index_Type (E));
 347          end if;
 348
 349       elsif Present (Index) then
 350          Error_Msg_N ("invalid entry index in accept for simple entry", N);
 351       end if;
 352
 353       --  If label declarations present, analyze them. They are declared
 354       --  in the enclosing task, but their enclosing scope is the entry itself,
 355       --  so that goto's to the label are recognized as local to the accept.
 356
 357       if Present (Declarations (N)) then
 358
 359          declare
 360             Decl : Node_Id;
 361             Id   : Entity_Id;
 362
 363          begin
 364             Decl := First (Declarations (N));
 365
 366             while Present (Decl) loop
 367                Analyze (Decl);
 368
 369                pragma Assert
 370                  (Nkind (Decl) = N_Implicit_Label_Declaration);
 371
 372                Id := Defining_Identifier (Decl);
 373                Set_Enclosing_Scope (Id, Entry_Nam);
 374                Next (Decl);
 375             end loop;
 376          end;
 377       end if;
 378
 379       --  If statements are present, they must be analyzed in the context
 380       --  of the entry, so that references to formals are correctly resolved.
 381       --  We also have to add the declarations that are required by the
 382       --  expansion of the accept statement in this case if expansion active.
 383
 384       --  In the case of a select alternative of a selective accept,
 385       --  the expander references the address declaration even if there
 386       --  is no statement list.
 387       --  We also need to create the renaming declarations for the local
 388       --  variables that will replace references to the formals within
 389       --  the accept.
 390
 391       Exp_Ch9.Expand_Accept_Declarations (N, Entry_Nam);
 392
 393       --  Set Never_Set_In_Source and clear Is_True_Constant/Current_Value
 394       --  fields on all entry formals (this loop ignores all other entities).
 395       --  Reset Set_Referenced and Has_Pragma_Unreferenced as well, so that
 396       --  we can post accurate warnings on each accept statement for the same
 397       --  entry.
 398
 399       E := First_Entity (Entry_Nam);
 400       while Present (E) loop
 401          if Is_Formal (E) then
 402             Set_Never_Set_In_Source     (E, True);
 403             Set_Is_True_Constant        (E, False);
 404             Set_Current_Value           (E, Empty);
 405             Set_Referenced              (E, False);
 406             Set_Has_Pragma_Unreferenced (E, False);
 407          end if;
 408
 409          Next_Entity (E);
 410       end loop;
 411
 412       --  Analyze statements if present
 413
 414       if Present (Stats) then
 415          New_Scope (Entry_Nam);
 416          Install_Declarations (Entry_Nam);
 417
 418          Set_Actual_Subtypes (N, Current_Scope);
 419
 420          Analyze (Stats);
 421          Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Nam);
 422          End_Scope;
 423       end if;
 424
 425       --  Some warning checks
 426
 427       Check_Potentially_Blocking_Operation (N);
 428       Check_References (Entry_Nam, N);
 429       Set_Entry_Accepted (Entry_Nam);
 430    end Analyze_Accept_Statement;
 431
 432    ---------------------------------
 433    -- Analyze_Asynchronous_Select --
 434    ---------------------------------
 435
 436    procedure Analyze_Asynchronous_Select (N : Node_Id) is
 437    begin
 438       Tasking_Used := True;
 439       Check_Restriction (Max_Asynchronous_Select_Nesting, N);
 440       Check_Restriction (No_Select_Statements, N);
 441
 442       --  Analyze the statements. We analyze statements in the abortable part
 443       --  first, because this is the section that is executed first, and that
 444       --  way our remembering of saved values and checks is accurate.
 445
 446       Analyze_Statements (Statements (Abortable_Part (N)));
 447       Analyze (Triggering_Alternative (N));
 448    end Analyze_Asynchronous_Select;
 449
 450    ------------------------------------
 451    -- Analyze_Conditional_Entry_Call --
 452    ------------------------------------
 453
 454    procedure Analyze_Conditional_Entry_Call (N : Node_Id) is
 455    begin
 456       Check_Restriction (No_Select_Statements, N);
 457       Tasking_Used := True;
 458       Analyze (Entry_Call_Alternative (N));
 459       Analyze_Statements (Else_Statements (N));
 460    end Analyze_Conditional_Entry_Call;
 461
 462    --------------------------------
 463    -- Analyze_Delay_Alternative  --
 464    --------------------------------
 465
 466    procedure Analyze_Delay_Alternative (N : Node_Id) is
 467       Expr : Node_Id;
 468
 469    begin
 470       Tasking_Used := True;
 471       Check_Restriction (No_Delay, N);
 472
 473       if Present (Pragmas_Before (N)) then
 474          Analyze_List (Pragmas_Before (N));
 475       end if;
 476
 477       if Nkind (Parent (N)) = N_Selective_Accept
 478         or else Nkind (Parent (N)) = N_Timed_Entry_Call
 479       then
 480          Expr := Expression (Delay_Statement (N));
 481
 482          --  defer full analysis until the statement is expanded, to insure
 483          --  that generated code does not move past the guard. The delay
 484          --  expression is only evaluated if the guard is open.
 485
 486          if Nkind (Delay_Statement (N)) = N_Delay_Relative_Statement then
 487             Pre_Analyze_And_Resolve (Expr, Standard_Duration);
 488
 489          else
 490             Pre_Analyze_And_Resolve (Expr);
 491          end if;
 492
 493          if Nkind (Delay_Statement (N)) = N_Delay_Until_Statement and then
 494             not Is_RTE (Base_Type (Etype (Expr)), RO_CA_Time)     and then
 495             not Is_RTE (Base_Type (Etype (Expr)), RO_RT_Time)
 496          then
 497             Error_Msg_N ("expect Time types for `DELAY UNTIL`", Expr);
 498          end if;
 499
 500          Check_Restriction (No_Fixed_Point, Expr);
 501       else
 502          Analyze (Delay_Statement (N));
 503       end if;
 504
 505       if Present (Condition (N)) then
 506          Analyze_And_Resolve (Condition (N), Any_Boolean);
 507       end if;
 508
 509       if Is_Non_Empty_List (Statements (N)) then
 510          Analyze_Statements (Statements (N));
 511       end if;
 512    end Analyze_Delay_Alternative;
 513
 514    ----------------------------
 515    -- Analyze_Delay_Relative --
 516    ----------------------------
 517
 518    procedure Analyze_Delay_Relative (N : Node_Id) is
 519       E : constant Node_Id := Expression (N);
 520
 521    begin
 522       Check_Restriction (No_Relative_Delay, N);
 523       Tasking_Used := True;
 524       Check_Restriction (No_Delay, N);
 525       Check_Potentially_Blocking_Operation (N);
 526       Analyze_And_Resolve (E, Standard_Duration);
 527       Check_Restriction (No_Fixed_Point, E);
 528    end Analyze_Delay_Relative;
 529
 530    -------------------------
 531    -- Analyze_Delay_Until --
 532    -------------------------
 533
 534    procedure Analyze_Delay_Until (N : Node_Id) is
 535       E : constant Node_Id := Expression (N);
 536
 537    begin
 538       Tasking_Used := True;
 539       Check_Restriction (No_Delay, N);
 540       Check_Potentially_Blocking_Operation (N);
 541       Analyze (E);
 542
 543       if not Is_RTE (Base_Type (Etype (E)), RO_CA_Time) and then
 544          not Is_RTE (Base_Type (Etype (E)), RO_RT_Time)
 545       then
 546          Error_Msg_N ("expect Time types for `DELAY UNTIL`", E);
 547       end if;
 548    end Analyze_Delay_Until;
 549
 550    ------------------------
 551    -- Analyze_Entry_Body --
 552    ------------------------
 553
 554    procedure Analyze_Entry_Body (N : Node_Id) is
 555       Id         : constant Entity_Id := Defining_Identifier (N);
 556       Decls      : constant List_Id   := Declarations (N);
 557       Stats      : constant Node_Id   := Handled_Statement_Sequence (N);
 558       Formals    : constant Node_Id   := Entry_Body_Formal_Part (N);
 559       P_Type     : constant Entity_Id := Current_Scope;
 560       Entry_Name : Entity_Id;
 561       E          : Entity_Id;
 562
 563    begin
 564       Tasking_Used := True;
 565
 566       --  Entry_Name is initialized to Any_Id. It should get reset to the
 567       --  matching entry entity. An error is signalled if it is not reset
 568
 569       Entry_Name := Any_Id;
 570
 571       Analyze (Formals);
 572
 573       if Present (Entry_Index_Specification (Formals)) then
 574          Set_Ekind (Id, E_Entry_Family);
 575       else
 576          Set_Ekind (Id, E_Entry);
 577       end if;
 578
 579       Set_Scope          (Id, Current_Scope);
 580       Set_Etype          (Id, Standard_Void_Type);
 581       Set_Accept_Address (Id, New_Elmt_List);
 582
 583       E := First_Entity (P_Type);
 584       while Present (E) loop
 585          if Chars (E) = Chars (Id)
 586            and then (Ekind (E) = Ekind (Id))
 587            and then Type_Conformant (Id, E)
 588          then
 589             Entry_Name := E;
 590             Set_Convention (Id, Convention (E));
 591             Set_Corresponding_Body (Parent (Entry_Name), Id);
 592             Check_Fully_Conformant (Id, E, N);
 593
 594             if Ekind (Id) = E_Entry_Family then
 595                if not Fully_Conformant_Discrete_Subtypes (
 596                   Discrete_Subtype_Definition (Parent (E)),
 597                   Discrete_Subtype_Definition
 598                     (Entry_Index_Specification (Formals)))
 599                then
 600                   Error_Msg_N
 601                     ("index not fully conformant with previous declaration",
 602                       Discrete_Subtype_Definition
 603                        (Entry_Index_Specification (Formals)));
 604
 605                else
 606                   --  The elaboration of the entry body does not recompute
 607                   --  the bounds of the index, which may have side effects.
 608                   --  Inherit the bounds from the entry declaration. This
 609                   --  is critical if the entry has a per-object constraint.
 610                   --  If a bound is given by a discriminant, it must be
 611                   --  reanalyzed in order to capture the discriminal of the
 612                   --  current entry, rather than that of the protected type.
 613
 614                   declare
 615                      Index_Spec : constant Node_Id :=
 616                                     Entry_Index_Specification (Formals);
 617
 618                      Def : constant Node_Id :=
 619                              New_Copy_Tree
 620                                (Discrete_Subtype_Definition (Parent (E)));
 621
 622                   begin
 623                      if Nkind
 624                        (Original_Node
 625                          (Discrete_Subtype_Definition (Index_Spec))) = N_Range
 626                      then
 627                         Set_Etype (Def, Empty);
 628                         Set_Analyzed (Def, False);
 629                         Set_Discrete_Subtype_Definition (Index_Spec, Def);
 630                         Set_Analyzed (Low_Bound (Def), False);
 631                         Set_Analyzed (High_Bound (Def), False);
 632
 633                         if Denotes_Discriminant (Low_Bound (Def)) then
 634                            Set_Entity (Low_Bound (Def), Empty);
 635                         end if;
 636
 637                         if Denotes_Discriminant (High_Bound (Def)) then
 638                            Set_Entity (High_Bound (Def), Empty);
 639                         end if;
 640
 641                         Analyze (Def);
 642                         Make_Index (Def, Index_Spec);
 643                         Set_Etype
 644                           (Defining_Identifier (Index_Spec), Etype (Def));
 645                      end if;
 646                   end;
 647                end if;
 648             end if;
 649
 650             exit;
 651          end if;
 652
 653          Next_Entity (E);
 654       end loop;
 655
 656       if Entry_Name = Any_Id then
 657          Error_Msg_N ("no entry declaration matches entry body",  N);
 658          return;
 659
 660       elsif Has_Completion (Entry_Name) then
 661          Error_Msg_N ("duplicate entry body", N);
 662          return;
 663
 664       else
 665          Set_Has_Completion (Entry_Name);
 666          Generate_Reference (Entry_Name, Id, 'b', Set_Ref => False);
 667          Style.Check_Identifier (Id, Entry_Name);
 668       end if;
 669
 670       Exp_Ch9.Expand_Entry_Barrier (N, Entry_Name);
 671       New_Scope (Entry_Name);
 672
 673       Exp_Ch9.Expand_Entry_Body_Declarations (N);
 674       Install_Declarations (Entry_Name);
 675       Set_Actual_Subtypes (N, Current_Scope);
 676
 677       --  The entity for the protected subprogram corresponding to the entry
 678       --  has been created. We retain the name of this entity in the entry
 679       --  body, for use when the corresponding subprogram body is created.
 680       --  Note that entry bodies have to corresponding_spec, and there is no
 681       --  easy link back in the tree between the entry body and the entity for
 682       --  the entry itself.
 683
 684       Set_Protected_Body_Subprogram (Id,
 685         Protected_Body_Subprogram (Entry_Name));
 686
 687       if Present (Decls) then
 688          Analyze_Declarations (Decls);
 689       end if;
 690
 691       if Present (Stats) then
 692          Analyze (Stats);
 693       end if;
 694
 695       --  Check for unreferenced variables etc. Before the Check_References
 696       --  call, we transfer Never_Set_In_Source and Referenced flags from
 697       --  parameters in the spec to the corresponding entities in the body,
 698       --  since we want the warnings on the body entities. Note that we do
 699       --  not have to transfer Referenced_As_LHS, since that flag can only
 700       --  be set for simple variables.
 701
 702       --  At the same time, we set the flags on the spec entities to suppress
 703       --  any warnings on the spec formals, since we also scan the spec.
 704
 705       declare
 706          E1  : Entity_Id;
 707          E2  : Entity_Id;
 708
 709       begin
 710          E1 := First_Entity (Entry_Name);
 711          while Present (E1) loop
 712             E2 := First_Entity (Id);
 713             while Present (E2) loop
 714                exit when Chars (E1) = Chars (E2);
 715                Next_Entity (E2);
 716             end loop;
 717
 718             --  If no matching body entity, then we already had
 719             --  a detected error of some kind, so just forget
 720             --  about worrying about these warnings.
 721
 722             if No (E2) then
 723                goto Continue;
 724             end if;
 725
 726             if Ekind (E1) = E_Out_Parameter then
 727                Set_Never_Set_In_Source (E2, Never_Set_In_Source (E1));
 728                Set_Never_Set_In_Source (E1, False);
 729             end if;
 730
 731             Set_Referenced (E2, Referenced (E1));
 732             Set_Referenced (E1);
 733
 734          <<Continue>>
 735             Next_Entity (E1);
 736          end loop;
 737
 738          Check_References (Id);
 739       end;
 740
 741       --  We still need to check references for the spec, since objects
 742       --  declared in the body are chained (in the First_Entity sense) to
 743       --  the spec rather than the body in the case of entries.
 744
 745       Check_References (Entry_Name);
 746
 747       --  Process the end label, and terminate the scope
 748
 749       Process_End_Label (Handled_Statement_Sequence (N), 't', Entry_Name);
 750       End_Scope;
 751
 752       --  If this is an entry family, remove the loop created to provide
 753       --  a scope for the entry index.
 754
 755       if Ekind (Id) = E_Entry_Family
 756         and then Present (Entry_Index_Specification (Formals))
 757       then
 758          End_Scope;
 759       end if;
 760
 761    end Analyze_Entry_Body;
 762
 763    ------------------------------------
 764    -- Analyze_Entry_Body_Formal_Part --
 765    ------------------------------------
 766
 767    procedure Analyze_Entry_Body_Formal_Part (N : Node_Id) is
 768       Id      : constant Entity_Id := Defining_Identifier (Parent (N));
 769       Index   : constant Node_Id   := Entry_Index_Specification (N);
 770       Formals : constant List_Id   := Parameter_Specifications (N);
 771
 772    begin
 773       Tasking_Used := True;
 774
 775       if Present (Index) then
 776          Analyze (Index);
 777       end if;
 778
 779       if Present (Formals) then
 780          Set_Scope (Id, Current_Scope);
 781          New_Scope (Id);
 782          Process_Formals (Formals, Parent (N));
 783          End_Scope;
 784       end if;
 785    end Analyze_Entry_Body_Formal_Part;
 786
 787    ------------------------------------
 788    -- Analyze_Entry_Call_Alternative --
 789    ------------------------------------
 790
 791    procedure Analyze_Entry_Call_Alternative (N : Node_Id) is
 792       Call : constant Node_Id := Entry_Call_Statement (N);
 793
 794    begin
 795       Tasking_Used := True;
 796
 797       if Present (Pragmas_Before (N)) then
 798          Analyze_List (Pragmas_Before (N));
 799       end if;
 800
 801       if Nkind (Call) = N_Attribute_Reference then
 802
 803          --  Possibly a stream attribute, but definitely illegal. Other
 804          --  illegalitles, such as procedure calls, are diagnosed after
 805          --  resolution.
 806
 807          Error_Msg_N ("entry call alternative requires an entry call", Call);
 808          return;
 809       end if;
 810
 811       Analyze (Call);
 812
 813       if Is_Non_Empty_List (Statements (N)) then
 814          Analyze_Statements (Statements (N));
 815       end if;
 816    end Analyze_Entry_Call_Alternative;
 817
 818    -------------------------------
 819    -- Analyze_Entry_Declaration --
 820    -------------------------------
 821
 822    procedure Analyze_Entry_Declaration (N : Node_Id) is
 823       Formals : constant List_Id   := Parameter_Specifications (N);
 824       Id      : constant Entity_Id := Defining_Identifier (N);
 825       D_Sdef  : constant Node_Id   := Discrete_Subtype_Definition (N);
 826
 827    begin
 828       Generate_Definition (Id);
 829       Tasking_Used := True;
 830
 831       if No (D_Sdef) then
 832          Set_Ekind (Id, E_Entry);
 833       else
 834          Enter_Name (Id);
 835          Set_Ekind (Id, E_Entry_Family);
 836          Analyze (D_Sdef);
 837          Make_Index (D_Sdef, N, Id);
 838       end if;
 839
 840       Set_Etype          (Id, Standard_Void_Type);
 841       Set_Convention     (Id, Convention_Entry);
 842       Set_Accept_Address (Id, New_Elmt_List);
 843
 844       if Present (Formals) then
 845          Set_Scope (Id, Current_Scope);
 846          New_Scope (Id);
 847          Process_Formals (Formals, N);
 848          Create_Extra_Formals (Id);
 849          End_Scope;
 850       end if;
 851
 852       if Ekind (Id) = E_Entry then
 853          New_Overloaded_Entity (Id);
 854       end if;
 855    end Analyze_Entry_Declaration;
 856
 857    ---------------------------------------
 858    -- Analyze_Entry_Index_Specification --
 859    ---------------------------------------
 860
 861    --  The defining_Identifier of the entry index specification is local
 862    --  to the entry body, but must be available in the entry barrier,
 863    --  which is evaluated outside of the entry body. The index is eventually
 864    --  renamed as a run-time object, so is visibility is strictly a front-end
 865    --  concern. In order to make it available to the barrier, we create
 866    --  an additional scope, as for a loop, whose only declaration is the
 867    --  index name. This loop is not attached to the tree and does not appear
 868    --  as an entity local to the protected type, so its existence need only
 869    --  be knwown to routines that process entry families.
 870
 871    procedure Analyze_Entry_Index_Specification (N : Node_Id) is
 872       Iden    : constant Node_Id   := Defining_Identifier (N);
 873       Def     : constant Node_Id   := Discrete_Subtype_Definition (N);
 874       Loop_Id : constant Entity_Id :=
 875                   Make_Defining_Identifier (Sloc (N),
 876                     Chars => New_Internal_Name ('L'));
 877
 878    begin
 879       Tasking_Used := True;
 880       Analyze (Def);
 881
 882       --  There is no elaboration of the entry index specification. Therefore,
 883       --  if the index is a range, it is not resolved and expanded, but the
 884       --  bounds are inherited from the entry declaration, and reanalyzed.
 885       --  See Analyze_Entry_Body.
 886
 887       if Nkind (Def) /= N_Range then
 888          Make_Index (Def, N);
 889       end if;
 890
 891       Set_Ekind (Loop_Id, E_Loop);
 892       Set_Scope (Loop_Id, Current_Scope);
 893       New_Scope (Loop_Id);
 894       Enter_Name (Iden);
 895       Set_Ekind (Iden, E_Entry_Index_Parameter);
 896       Set_Etype (Iden, Etype (Def));
 897    end Analyze_Entry_Index_Specification;
 898
 899    ----------------------------
 900    -- Analyze_Protected_Body --
 901    ----------------------------
 902
 903    procedure Analyze_Protected_Body (N : Node_Id) is
 904       Body_Id   : constant Entity_Id := Defining_Identifier (N);
 905       Last_E    : Entity_Id;
 906
 907       Spec_Id : Entity_Id;
 908       --  This is initially the entity of the protected object or protected
 909       --  type involved, but is replaced by the protected type always in the
 910       --  case of a single protected declaration, since this is the proper
 911       --  scope to be used.
 912
 913       Ref_Id : Entity_Id;
 914       --  This is the entity of the protected object or protected type
 915       --  involved, and is the entity used for cross-reference purposes
 916       --  (it differs from Spec_Id in the case of a single protected
 917       --  object, since Spec_Id is set to the protected type in this case).
 918
 919    begin
 920       Tasking_Used := True;
 921       Set_Ekind (Body_Id, E_Protected_Body);
 922       Spec_Id := Find_Concurrent_Spec (Body_Id);
 923
 924       if Present (Spec_Id)
 925         and then Ekind (Spec_Id) = E_Protected_Type
 926       then
 927          null;
 928
 929       elsif Present (Spec_Id)
 930         and then Ekind (Etype (Spec_Id)) = E_Protected_Type
 931         and then not Comes_From_Source (Etype (Spec_Id))
 932       then
 933          null;
 934
 935       else
 936          Error_Msg_N ("missing specification for protected body", Body_Id);
 937          return;
 938       end if;
 939
 940       Ref_Id := Spec_Id;
 941       Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
 942       Style.Check_Identifier (Body_Id, Spec_Id);
 943
 944       --  The declarations are always attached to the type
 945
 946       if Ekind (Spec_Id) /= E_Protected_Type then
 947          Spec_Id := Etype (Spec_Id);
 948       end if;
 949
 950       New_Scope (Spec_Id);
 951       Set_Corresponding_Spec (N, Spec_Id);
 952       Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
 953       Set_Has_Completion (Spec_Id);
 954       Install_Declarations (Spec_Id);
 955
 956       Exp_Ch9.Expand_Protected_Body_Declarations (N, Spec_Id);
 957
 958       Last_E := Last_Entity (Spec_Id);
 959
 960       Analyze_Declarations (Declarations (N));
 961
 962       --  For visibility purposes, all entities in the body are private.
 963       --  Set First_Private_Entity accordingly, if there was no private
 964       --  part in the protected declaration.
 965
 966       if No (First_Private_Entity (Spec_Id)) then
 967          if Present (Last_E) then
 968             Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
 969          else
 970             Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
 971          end if;
 972       end if;
 973
 974       Check_Completion (Body_Id);
 975       Check_References (Spec_Id);
 976       Process_End_Label (N, 't', Ref_Id);
 977       End_Scope;
 978    end Analyze_Protected_Body;
 979
 980    ----------------------------------
 981    -- Analyze_Protected_Definition --
 982    ----------------------------------
 983
 984    procedure Analyze_Protected_Definition (N : Node_Id) is
 985       E : Entity_Id;
 986       L : Entity_Id;
 987
 988    begin
 989       Tasking_Used := True;
 990       Analyze_Declarations (Visible_Declarations (N));
 991
 992       if Present (Private_Declarations (N))
 993         and then not Is_Empty_List (Private_Declarations (N))
 994       then
 995          L := Last_Entity (Current_Scope);
 996          Analyze_Declarations (Private_Declarations (N));
 997
 998          if Present (L) then
 999             Set_First_Private_Entity (Current_Scope, Next_Entity (L));
1000
1001          else
1002             Set_First_Private_Entity (Current_Scope,
1003               First_Entity (Current_Scope));
1004          end if;
1005       end if;
1006
1007       E := First_Entity (Current_Scope);
1008
1009       while Present (E) loop
1010
1011          if Ekind (E) = E_Function
1012            or else Ekind (E) = E_Procedure
1013          then
1014             Set_Convention (E, Convention_Protected);
1015
1016          elsif Is_Task_Type (Etype (E))
1017            or else Has_Task (Etype (E))
1018          then
1019             Set_Has_Task (Current_Scope);
1020          end if;
1021
1022          Next_Entity (E);
1023       end loop;
1024
1025       Check_Max_Entries (N, Max_Protected_Entries);
1026       Process_End_Label (N, 'e', Current_Scope);
1027    end Analyze_Protected_Definition;
1028
1029    ----------------------------
1030    -- Analyze_Protected_Type --
1031    ----------------------------
1032
1033    procedure Analyze_Protected_Type (N : Node_Id) is
1034       E      : Entity_Id;
1035       T      : Entity_Id;
1036       Def_Id : constant Entity_Id := Defining_Identifier (N);
1037
1038    begin
1039       if No_Run_Time_Mode then
1040          Error_Msg_CRT ("protected type", N);
1041          return;
1042       end if;
1043
1044       Tasking_Used := True;
1045       Check_Restriction (No_Protected_Types, N);
1046
1047       T := Find_Type_Name (N);
1048
1049       if Ekind (T) = E_Incomplete_Type then
1050          T := Full_View (T);
1051          Set_Completion_Referenced (T);
1052       end if;
1053
1054       Set_Ekind              (T, E_Protected_Type);
1055       Init_Size_Align        (T);
1056       Set_Etype              (T, T);
1057       Set_Is_First_Subtype   (T, True);
1058       Set_Has_Delayed_Freeze (T, True);
1059       Set_Stored_Constraint  (T, No_Elist);
1060       New_Scope (T);
1061
1062       if Present (Discriminant_Specifications (N)) then
1063          if Has_Discriminants (T) then
1064
1065             --  Install discriminants. Also, verify conformance of
1066             --  discriminants of previous and current view.  ???
1067
1068             Install_Declarations (T);
1069          else
1070             Process_Discriminants (N);
1071          end if;
1072       end if;
1073
1074       Analyze (Protected_Definition (N));
1075
1076       --  Protected types with entries are controlled (because of the
1077       --  Protection component if nothing else), same for any protected type
1078       --  with interrupt handlers. Note that we need to analyze the protected
1079       --  definition to set Has_Entries and such.
1080
1081       if (Abort_Allowed or else Restriction_Active (No_Entry_Queue) = False
1082            or else Number_Entries (T) > 1)
1083         and then
1084           (Has_Entries (T)
1085             or else Has_Interrupt_Handler (T)
1086             or else Has_Attach_Handler (T))
1087       then
1088          Set_Has_Controlled_Component (T, True);
1089       end if;
1090
1091       --  The Ekind of components is E_Void during analysis to detect
1092       --  illegal uses. Now it can be set correctly.
1093
1094       E := First_Entity (Current_Scope);
1095
1096       while Present (E) loop
1097          if Ekind (E) = E_Void then
1098             Set_Ekind (E, E_Component);
1099             Init_Component_Location (E);
1100          end if;
1101
1102          Next_Entity (E);
1103       end loop;
1104
1105       End_Scope;
1106
1107       if T /= Def_Id
1108         and then Is_Private_Type (Def_Id)
1109         and then Has_Discriminants (Def_Id)
1110         and then Expander_Active
1111       then
1112          Exp_Ch9.Expand_N_Protected_Type_Declaration (N);
1113          Process_Full_View (N, T, Def_Id);
1114       end if;
1115    end Analyze_Protected_Type;
1116
1117    ---------------------
1118    -- Analyze_Requeue --
1119    ---------------------
1120
1121    procedure Analyze_Requeue (N : Node_Id) is
1122       Entry_Name : Node_Id := Name (N);
1123       Entry_Id   : Entity_Id;
1124       Found      : Boolean;
1125       I          : Interp_Index;
1126       It         : Interp;
1127       Enclosing  : Entity_Id;
1128       Target_Obj : Node_Id := Empty;
1129       Req_Scope  : Entity_Id;
1130       Outer_Ent  : Entity_Id;
1131
1132    begin
1133       Check_Restriction (No_Requeue_Statements, N);
1134       Check_Unreachable_Code (N);
1135       Tasking_Used := True;
1136
1137       Enclosing := Empty;
1138       for J in reverse 0 .. Scope_Stack.Last loop
1139          Enclosing := Scope_Stack.Table (J).Entity;
1140          exit when Is_Entry (Enclosing);
1141
1142          if Ekind (Enclosing) /= E_Block
1143            and then Ekind (Enclosing) /= E_Loop
1144          then
1145             Error_Msg_N ("requeue must appear within accept or entry body", N);
1146             return;
1147          end if;
1148       end loop;
1149
1150       Analyze (Entry_Name);
1151
1152       if Etype (Entry_Name) = Any_Type then
1153          return;
1154       end if;
1155
1156       if Nkind (Entry_Name) = N_Selected_Component then
1157          Target_Obj := Prefix (Entry_Name);
1158          Entry_Name := Selector_Name (Entry_Name);
1159       end if;
1160
1161       --  If an explicit target object is given then we have to check
1162       --  the restrictions of 9.5.4(6).
1163
1164       if Present (Target_Obj) then
1165
1166          --  Locate containing concurrent unit and determine enclosing entry
1167          --  body or outermost enclosing accept statement within the unit.
1168
1169          Outer_Ent := Empty;
1170          for S in reverse 0 .. Scope_Stack.Last loop
1171             Req_Scope := Scope_Stack.Table (S).Entity;
1172
1173             exit when Ekind (Req_Scope) in Task_Kind
1174               or else Ekind (Req_Scope) in Protected_Kind;
1175
1176             if Is_Entry (Req_Scope) then
1177                Outer_Ent := Req_Scope;
1178             end if;
1179          end loop;
1180
1181          pragma Assert (Present (Outer_Ent));
1182
1183          --  Check that the accessibility level of the target object
1184          --  is not greater or equal to the outermost enclosing accept
1185          --  statement (or entry body) unless it is a parameter of the
1186          --  innermost enclosing accept statement (or entry body).
1187
1188          if Object_Access_Level (Target_Obj) >= Scope_Depth (Outer_Ent)
1189            and then
1190              (not Is_Entity_Name (Target_Obj)
1191                or else Ekind (Entity (Target_Obj)) not in Formal_Kind
1192                or else Enclosing /= Scope (Entity (Target_Obj)))
1193          then
1194             Error_Msg_N
1195               ("target object has invalid level for requeue", Target_Obj);
1196          end if;
1197       end if;
1198
1199       --  Overloaded case, find right interpretation
1200
1201       if Is_Overloaded (Entry_Name) then
1202          Get_First_Interp (Entry_Name, I, It);
1203          Found := False;
1204          Entry_Id := Empty;
1205
1206          while Present (It.Nam) loop
1207             if No (First_Formal (It.Nam))
1208               or else Subtype_Conformant (Enclosing, It.Nam)
1209             then
1210                if not Found then
1211                   Found := True;
1212                   Entry_Id := It.Nam;
1213                else
1214                   Error_Msg_N ("ambiguous entry name in requeue", N);
1215                   return;
1216                end if;
1217             end if;
1218
1219             Get_Next_Interp (I, It);
1220          end loop;
1221
1222          if not Found then
1223             Error_Msg_N ("no entry matches context",  N);
1224             return;
1225          else
1226             Set_Entity (Entry_Name, Entry_Id);
1227          end if;
1228
1229       --  Non-overloaded cases
1230
1231       --  For the case of a reference to an element of an entry family,
1232       --  the Entry_Name is an indexed component.
1233
1234       elsif Nkind (Entry_Name) = N_Indexed_Component then
1235
1236          --  Requeue to an entry out of the body
1237
1238          if Nkind (Prefix (Entry_Name)) = N_Selected_Component then
1239             Entry_Id := Entity (Selector_Name (Prefix (Entry_Name)));
1240
1241          --  Requeue from within the body itself
1242
1243          elsif Nkind (Prefix (Entry_Name)) = N_Identifier then
1244             Entry_Id := Entity (Prefix (Entry_Name));
1245
1246          else
1247             Error_Msg_N ("invalid entry_name specified",  N);
1248             return;
1249          end if;
1250
1251       --  If we had a requeue of the form REQUEUE A (B), then the parser
1252       --  accepted it (because it could have been a requeue on an entry
1253       --  index. If A turns out not to be an entry family, then the analysis
1254       --  of A (B) turned it into a function call.
1255
1256       elsif Nkind (Entry_Name) = N_Function_Call then
1257          Error_Msg_N
1258            ("arguments not allowed in requeue statement",
1259             First (Parameter_Associations (Entry_Name)));
1260          return;
1261
1262       --  Normal case of no entry family, no argument
1263
1264       else
1265          Entry_Id := Entity (Entry_Name);
1266       end if;
1267
1268       --  Resolve entry, and check that it is subtype conformant with the
1269       --  enclosing construct if this construct has formals (RM 9.5.4(5)).
1270
1271       if not Is_Entry (Entry_Id) then
1272          Error_Msg_N ("expect entry name in requeue statement", Name (N));
1273       elsif Ekind (Entry_Id) = E_Entry_Family
1274         and then Nkind (Entry_Name) /= N_Indexed_Component
1275       then
1276          Error_Msg_N ("missing index for entry family component", Name (N));
1277
1278       else
1279          Resolve_Entry (Name (N));
1280          Generate_Reference (Entry_Id, Entry_Name);
1281
1282          if Present (First_Formal (Entry_Id)) then
1283             Check_Subtype_Conformant (Enclosing, Entry_Id, Name (N));
1284
1285             --  Processing for parameters accessed by the requeue
1286
1287             declare
1288                Ent : Entity_Id := First_Formal (Enclosing);
1289
1290             begin
1291                while Present (Ent) loop
1292
1293                   --  For OUT or IN OUT parameter, the effect of the requeue
1294                   --  is to assign the parameter a value on exit from the
1295                   --  requeued body, so we can set it as source assigned.
1296                   --  We also clear the Is_True_Constant indication. We do
1297                   --  not need to clear Current_Value, since the effect of
1298                   --  the requeue is to perform an unconditional goto so
1299                   --  that any further references will not occur anyway.
1300
1301                   if Ekind (Ent) = E_Out_Parameter
1302                        or else
1303                      Ekind (Ent) = E_In_Out_Parameter
1304                   then
1305                      Set_Never_Set_In_Source (Ent, False);
1306                      Set_Is_True_Constant    (Ent, False);
1307                   end if;
1308
1309                   --  For all parameters, the requeue acts as a reference,
1310                   --  since the value of the parameter is passed to the
1311                   --  new entry, so we want to suppress unreferenced warnings.
1312
1313                   Set_Referenced (Ent);
1314                   Next_Formal (Ent);
1315                end loop;
1316             end;
1317          end if;
1318       end if;
1319    end Analyze_Requeue;
1320
1321    ------------------------------
1322    -- Analyze_Selective_Accept --
1323    ------------------------------
1324
1325    procedure Analyze_Selective_Accept (N : Node_Id) is
1326       Alts : constant List_Id := Select_Alternatives (N);
1327       Alt  : Node_Id;
1328
1329       Accept_Present    : Boolean := False;
1330       Terminate_Present : Boolean := False;
1331       Delay_Present     : Boolean := False;
1332       Relative_Present  : Boolean := False;
1333       Alt_Count         : Uint    := Uint_0;
1334
1335    begin
1336       Check_Restriction (No_Select_Statements, N);
1337       Tasking_Used := True;
1338
1339       Alt := First (Alts);
1340       while Present (Alt) loop
1341          Alt_Count := Alt_Count + 1;
1342          Analyze (Alt);
1343
1344          if Nkind (Alt) = N_Delay_Alternative then
1345             if Delay_Present then
1346
1347                if Relative_Present /=
1348                    (Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement)
1349                then
1350                   Error_Msg_N
1351                     ("delay_until and delay_relative alternatives ", Alt);
1352                   Error_Msg_N
1353                     ("\cannot appear in the same selective_wait", Alt);
1354                end if;
1355
1356             else
1357                Delay_Present := True;
1358                Relative_Present :=
1359                  Nkind (Delay_Statement (Alt)) = N_Delay_Relative_Statement;
1360             end if;
1361
1362          elsif Nkind (Alt) = N_Terminate_Alternative then
1363             if Terminate_Present then
1364                Error_Msg_N ("Only one terminate alternative allowed", N);
1365             else
1366                Terminate_Present := True;
1367                Check_Restriction (No_Terminate_Alternatives, N);
1368             end if;
1369
1370          elsif Nkind (Alt) = N_Accept_Alternative then
1371             Accept_Present := True;
1372
1373             --  Check for duplicate accept
1374
1375             declare
1376                Alt1 : Node_Id;
1377                Stm  : constant Node_Id := Accept_Statement (Alt);
1378                EDN  : constant Node_Id := Entry_Direct_Name (Stm);
1379                Ent  : Entity_Id;
1380
1381             begin
1382                if Nkind (EDN) = N_Identifier
1383                  and then No (Condition (Alt))
1384                  and then Present (Entity (EDN)) -- defend against junk
1385                  and then Ekind (Entity (EDN)) = E_Entry
1386                then
1387                   Ent := Entity (EDN);
1388
1389                   Alt1 := First (Alts);
1390                   while Alt1 /= Alt loop
1391                      if Nkind (Alt1) = N_Accept_Alternative
1392                        and then No (Condition (Alt1))
1393                      then
1394                         declare
1395                            Stm1 : constant Node_Id := Accept_Statement (Alt1);
1396                            EDN1 : constant Node_Id := Entry_Direct_Name (Stm1);
1397
1398                         begin
1399                            if Nkind (EDN1) = N_Identifier then
1400                               if Entity (EDN1) = Ent then
1401                                  Error_Msg_Sloc := Sloc (Stm1);
1402                                  Error_Msg_N
1403                                    ("?accept duplicates one on line#", Stm);
1404                                  exit;
1405                               end if;
1406                            end if;
1407                         end;
1408                      end if;
1409
1410                      Next (Alt1);
1411                   end loop;
1412                end if;
1413             end;
1414          end if;
1415
1416          Next (Alt);
1417       end loop;
1418
1419       Check_Restriction (Max_Select_Alternatives, N, Alt_Count);
1420       Check_Potentially_Blocking_Operation (N);
1421
1422       if Terminate_Present and Delay_Present then
1423          Error_Msg_N ("at most one of terminate or delay alternative", N);
1424
1425       elsif not Accept_Present then
1426          Error_Msg_N
1427            ("select must contain at least one accept alternative", N);
1428       end if;
1429
1430       if Present (Else_Statements (N)) then
1431          if Terminate_Present or Delay_Present then
1432             Error_Msg_N ("else part not allowed with other alternatives", N);
1433          end if;
1434
1435          Analyze_Statements (Else_Statements (N));
1436       end if;
1437    end Analyze_Selective_Accept;
1438
1439    ------------------------------
1440    -- Analyze_Single_Protected --
1441    ------------------------------
1442
1443    procedure Analyze_Single_Protected (N : Node_Id) is
1444       Loc    : constant Source_Ptr := Sloc (N);
1445       Id     : constant Node_Id    := Defining_Identifier (N);
1446       T      : Entity_Id;
1447       T_Decl : Node_Id;
1448       O_Decl : Node_Id;
1449       O_Name : constant Entity_Id := New_Copy (Id);
1450
1451    begin
1452       Generate_Definition (Id);
1453       Tasking_Used := True;
1454
1455       --  The node is rewritten as a protected type declaration,
1456       --  in exact analogy with what is done with single tasks.
1457
1458       T :=
1459         Make_Defining_Identifier (Sloc (Id),
1460           New_External_Name (Chars (Id), 'T'));
1461
1462       T_Decl :=
1463         Make_Protected_Type_Declaration (Loc,
1464          Defining_Identifier => T,
1465          Protected_Definition => Relocate_Node (Protected_Definition (N)));
1466
1467       O_Decl :=
1468         Make_Object_Declaration (Loc,
1469           Defining_Identifier => O_Name,
1470           Object_Definition   => Make_Identifier (Loc,  Chars (T)));
1471
1472       Rewrite (N, T_Decl);
1473       Insert_After (N, O_Decl);
1474       Mark_Rewrite_Insertion (O_Decl);
1475
1476       --  Enter names of type and object before analysis, because the name
1477       --  of the object may be used in its own body.
1478
1479       Enter_Name (T);
1480       Set_Ekind (T, E_Protected_Type);
1481       Set_Etype (T, T);
1482
1483       Enter_Name (O_Name);
1484       Set_Ekind (O_Name, E_Variable);
1485       Set_Etype (O_Name, T);
1486
1487       --  Instead of calling Analyze on the new node,  call directly
1488       --  the proper analysis procedure. Otherwise the node would be
1489       --  expanded twice, with disastrous result.
1490
1491       Analyze_Protected_Type (N);
1492
1493    end Analyze_Single_Protected;
1494
1495    -------------------------
1496    -- Analyze_Single_Task --
1497    -------------------------
1498
1499    procedure Analyze_Single_Task (N : Node_Id) is
1500       Loc    : constant Source_Ptr := Sloc (N);
1501       Id     : constant Node_Id    := Defining_Identifier (N);
1502       T      : Entity_Id;
1503       T_Decl : Node_Id;
1504       O_Decl : Node_Id;
1505       O_Name : constant Entity_Id := New_Copy (Id);
1506
1507    begin
1508       Generate_Definition (Id);
1509       Tasking_Used := True;
1510
1511       --  The node is rewritten as a task type declaration,  followed
1512       --  by an object declaration of that anonymous task type.
1513
1514       T :=
1515         Make_Defining_Identifier (Sloc (Id),
1516           New_External_Name (Chars (Id), Suffix => "TK"));
1517
1518       T_Decl :=
1519         Make_Task_Type_Declaration (Loc,
1520           Defining_Identifier => T,
1521           Task_Definition     => Relocate_Node (Task_Definition (N)));
1522
1523       O_Decl :=
1524         Make_Object_Declaration (Loc,
1525           Defining_Identifier => O_Name,
1526           Object_Definition   => Make_Identifier (Loc, Chars (T)));
1527
1528       Rewrite (N, T_Decl);
1529       Insert_After (N, O_Decl);
1530       Mark_Rewrite_Insertion (O_Decl);
1531
1532       --  Enter names of type and object before analysis, because the name
1533       --  of the object may be used in its own body.
1534
1535       Enter_Name (T);
1536       Set_Ekind (T, E_Task_Type);
1537       Set_Etype (T, T);
1538
1539       Enter_Name (O_Name);
1540       Set_Ekind (O_Name, E_Variable);
1541       Set_Etype (O_Name, T);
1542
1543       --  Instead of calling Analyze on the new node,  call directly
1544       --  the proper analysis procedure. Otherwise the node would be
1545       --  expanded twice, with disastrous result.
1546
1547       Analyze_Task_Type (N);
1548    end Analyze_Single_Task;
1549
1550    -----------------------
1551    -- Analyze_Task_Body --
1552    -----------------------
1553
1554    procedure Analyze_Task_Body (N : Node_Id) is
1555       Body_Id : constant Entity_Id := Defining_Identifier (N);
1556       Last_E  : Entity_Id;
1557
1558       Spec_Id : Entity_Id;
1559       --  This is initially the entity of the task or task type involved,
1560       --  but is replaced by the task type always in the case of a single
1561       --  task declaration, since this is the proper scope to be used.
1562
1563       Ref_Id : Entity_Id;
1564       --  This is the entity of the task or task type, and is the entity
1565       --  used for cross-reference purposes (it differs from Spec_Id in
1566       --  the case of a single task, since Spec_Id is set to the task type)
1567
1568    begin
1569       Tasking_Used := True;
1570       Set_Ekind (Body_Id, E_Task_Body);
1571       Set_Scope (Body_Id, Current_Scope);
1572       Spec_Id := Find_Concurrent_Spec (Body_Id);
1573
1574       --  The spec is either a task type declaration, or a single task
1575       --  declaration for which we have created an anonymous type.
1576
1577       if Present (Spec_Id)
1578         and then Ekind (Spec_Id) = E_Task_Type
1579       then
1580          null;
1581
1582       elsif Present (Spec_Id)
1583         and then Ekind (Etype (Spec_Id)) = E_Task_Type
1584         and then not Comes_From_Source (Etype (Spec_Id))
1585       then
1586          null;
1587
1588       else
1589          Error_Msg_N ("missing specification for task body", Body_Id);
1590          return;
1591       end if;
1592
1593       if Has_Completion (Spec_Id)
1594         and then Present (Corresponding_Body (Parent (Spec_Id)))
1595       then
1596          if Nkind (Parent (Spec_Id)) = N_Task_Type_Declaration then
1597             Error_Msg_NE ("duplicate body for task type&", N, Spec_Id);
1598
1599          else
1600             Error_Msg_NE ("duplicate body for task&", N, Spec_Id);
1601          end if;
1602       end if;
1603
1604       Ref_Id := Spec_Id;
1605       Generate_Reference (Ref_Id, Body_Id, 'b', Set_Ref => False);
1606       Style.Check_Identifier (Body_Id, Spec_Id);
1607
1608       --  Deal with case of body of single task (anonymous type was created)
1609
1610       if Ekind (Spec_Id) = E_Variable then
1611          Spec_Id := Etype (Spec_Id);
1612       end if;
1613
1614       New_Scope (Spec_Id);
1615       Set_Corresponding_Spec (N, Spec_Id);
1616       Set_Corresponding_Body (Parent (Spec_Id), Body_Id);
1617       Set_Has_Completion (Spec_Id);
1618       Install_Declarations (Spec_Id);
1619       Last_E := Last_Entity (Spec_Id);
1620
1621       Analyze_Declarations (Declarations (N));
1622
1623       --  For visibility purposes, all entities in the body are private.
1624       --  Set First_Private_Entity accordingly, if there was no private
1625       --  part in the protected declaration.
1626
1627       if No (First_Private_Entity (Spec_Id)) then
1628          if Present (Last_E) then
1629             Set_First_Private_Entity (Spec_Id, Next_Entity (Last_E));
1630          else
1631             Set_First_Private_Entity (Spec_Id, First_Entity (Spec_Id));
1632          end if;
1633       end if;
1634
1635       Analyze (Handled_Statement_Sequence (N));
1636       Check_Completion (Body_Id);
1637       Check_References (Body_Id);
1638       Check_References (Spec_Id);
1639
1640       --  Check for entries with no corresponding accept
1641
1642       declare
1643          Ent : Entity_Id;
1644
1645       begin
1646          Ent := First_Entity (Spec_Id);
1647
1648          while Present (Ent) loop
1649             if Is_Entry (Ent)
1650               and then not Entry_Accepted (Ent)
1651               and then Comes_From_Source (Ent)
1652             then
1653                Error_Msg_NE ("no accept for entry &?", N, Ent);
1654             end if;
1655
1656             Next_Entity (Ent);
1657          end loop;
1658       end;
1659
1660       Process_End_Label (Handled_Statement_Sequence (N), 't', Ref_Id);
1661       End_Scope;
1662    end Analyze_Task_Body;
1663
1664    -----------------------------
1665    -- Analyze_Task_Definition --
1666    -----------------------------
1667
1668    procedure Analyze_Task_Definition (N : Node_Id) is
1669       L : Entity_Id;
1670
1671    begin
1672       Tasking_Used := True;
1673
1674       if Present (Visible_Declarations (N)) then
1675          Analyze_Declarations (Visible_Declarations (N));
1676       end if;
1677
1678       if Present (Private_Declarations (N)) then
1679          L := Last_Entity (Current_Scope);
1680          Analyze_Declarations (Private_Declarations (N));
1681
1682          if Present (L) then
1683             Set_First_Private_Entity
1684               (Current_Scope, Next_Entity (L));
1685          else
1686             Set_First_Private_Entity
1687               (Current_Scope, First_Entity (Current_Scope));
1688          end if;
1689       end if;
1690
1691       Check_Max_Entries (N, Max_Task_Entries);
1692       Process_End_Label (N, 'e', Current_Scope);
1693    end Analyze_Task_Definition;
1694
1695    -----------------------
1696    -- Analyze_Task_Type --
1697    -----------------------
1698
1699    procedure Analyze_Task_Type (N : Node_Id) is
1700       T      : Entity_Id;
1701       Def_Id : constant Entity_Id := Defining_Identifier (N);
1702
1703    begin
1704       Check_Restriction (No_Tasking, N);
1705       Tasking_Used := True;
1706       T := Find_Type_Name (N);
1707       Generate_Definition (T);
1708
1709       if Ekind (T) = E_Incomplete_Type then
1710          T := Full_View (T);
1711          Set_Completion_Referenced (T);
1712       end if;
1713
1714       Set_Ekind              (T, E_Task_Type);
1715       Set_Is_First_Subtype   (T, True);
1716       Set_Has_Task           (T, True);
1717       Init_Size_Align        (T);
1718       Set_Etype              (T, T);
1719       Set_Has_Delayed_Freeze (T, True);
1720       Set_Stored_Constraint  (T, No_Elist);
1721       New_Scope (T);
1722
1723       if Present (Discriminant_Specifications (N)) then
1724          if Ada_Version = Ada_83 and then Comes_From_Source (N) then
1725             Error_Msg_N ("(Ada 83) task discriminant not allowed!", N);
1726          end if;
1727
1728          if Has_Discriminants (T) then
1729
1730             --  Install discriminants. Also, verify conformance of
1731             --  discriminants of previous and current view.  ???
1732
1733             Install_Declarations (T);
1734          else
1735             Process_Discriminants (N);
1736          end if;
1737       end if;
1738
1739       if Present (Task_Definition (N)) then
1740          Analyze_Task_Definition (Task_Definition (N));
1741       end if;
1742
1743       if not Is_Library_Level_Entity (T) then
1744          Check_Restriction (No_Task_Hierarchy, N);
1745       end if;
1746
1747       End_Scope;
1748
1749       if T /= Def_Id
1750         and then Is_Private_Type (Def_Id)
1751         and then Has_Discriminants (Def_Id)
1752         and then Expander_Active
1753       then
1754          Exp_Ch9.Expand_N_Task_Type_Declaration (N);
1755          Process_Full_View (N, T, Def_Id);
1756       end if;
1757    end Analyze_Task_Type;
1758
1759    -----------------------------------
1760    -- Analyze_Terminate_Alternative --
1761    -----------------------------------
1762
1763    procedure Analyze_Terminate_Alternative (N : Node_Id) is
1764    begin
1765       Tasking_Used := True;
1766
1767       if Present (Pragmas_Before (N)) then
1768          Analyze_List (Pragmas_Before (N));
1769       end if;
1770
1771       if Present (Condition (N)) then
1772          Analyze_And_Resolve (Condition (N), Any_Boolean);
1773       end if;
1774    end Analyze_Terminate_Alternative;
1775
1776    ------------------------------
1777    -- Analyze_Timed_Entry_Call --
1778    ------------------------------
1779
1780    procedure Analyze_Timed_Entry_Call (N : Node_Id) is
1781    begin
1782       Check_Restriction (No_Select_Statements, N);
1783       Tasking_Used := True;
1784       Analyze (Entry_Call_Alternative (N));
1785       Analyze (Delay_Alternative (N));
1786    end Analyze_Timed_Entry_Call;
1787
1788    ------------------------------------
1789    -- Analyze_Triggering_Alternative --
1790    ------------------------------------
1791
1792    procedure Analyze_Triggering_Alternative (N : Node_Id) is
1793       Trigger : constant Node_Id := Triggering_Statement (N);
1794
1795    begin
1796       Tasking_Used := True;
1797
1798       if Present (Pragmas_Before (N)) then
1799          Analyze_List (Pragmas_Before (N));
1800       end if;
1801
1802       Analyze (Trigger);
1803       if Comes_From_Source (Trigger)
1804         and then Nkind (Trigger) /= N_Delay_Until_Statement
1805         and then Nkind (Trigger) /= N_Delay_Relative_Statement
1806         and then Nkind (Trigger) /= N_Entry_Call_Statement
1807       then
1808          Error_Msg_N
1809           ("triggering statement must be delay or entry call", Trigger);
1810       end if;
1811
1812       if Is_Non_Empty_List (Statements (N)) then
1813          Analyze_Statements (Statements (N));
1814       end if;
1815    end Analyze_Triggering_Alternative;
1816
1817    -----------------------
1818    -- Check_Max_Entries --
1819    -----------------------
1820
1821    procedure Check_Max_Entries (D : Node_Id; R : All_Parameter_Restrictions) is
1822       Ecount : Uint;
1823
1824       procedure Count (L : List_Id);
1825       --  Count entries in given declaration list
1826
1827       -----------
1828       -- Count --
1829       -----------
1830
1831       procedure Count (L : List_Id) is
1832          D : Node_Id;
1833
1834       begin
1835          if No (L) then
1836             return;
1837          end if;
1838
1839          D := First (L);
1840          while Present (D) loop
1841             if Nkind (D) = N_Entry_Declaration then
1842                declare
1843                   DSD : constant Node_Id :=
1844                           Discrete_Subtype_Definition (D);
1845
1846                begin
1847                   --  If not an entry family, then just one entry
1848
1849                   if No (DSD) then
1850                      Ecount := Ecount + 1;
1851
1852                   --  If entry family with static bounds, count entries
1853
1854                   elsif Is_OK_Static_Subtype (Etype (DSD)) then
1855                      declare
1856                         Lo : constant Uint :=
1857                                Expr_Value
1858                                  (Type_Low_Bound (Etype (DSD)));
1859                         Hi : constant Uint :=
1860                                Expr_Value
1861                                  (Type_High_Bound (Etype (DSD)));
1862
1863                      begin
1864                         if Hi >= Lo then
1865                            Ecount := Ecount + Hi - Lo + 1;
1866                         end if;
1867                      end;
1868
1869                   --  Entry family with non-static bounds
1870
1871                   else
1872                      --  If restriction is set, then this is an error
1873
1874                      if Restrictions.Set (R) then
1875                         Error_Msg_N
1876                           ("static subtype required by Restriction pragma",
1877                            DSD);
1878
1879                      --  Otherwise we record an unknown count restriction
1880
1881                      else
1882                         Check_Restriction (R, D);
1883                      end if;
1884                   end if;
1885                end;
1886             end if;
1887
1888             Next (D);
1889          end loop;
1890       end Count;
1891
1892    --  Start of processing for Check_Max_Entries
1893
1894    begin
1895       Ecount := Uint_0;
1896       Count (Visible_Declarations (D));
1897       Count (Private_Declarations (D));
1898
1899       if Ecount > 0 then
1900          Check_Restriction (R, D, Ecount);
1901       end if;
1902    end Check_Max_Entries;
1903
1904    --------------------------
1905    -- Find_Concurrent_Spec --
1906    --------------------------
1907
1908    function Find_Concurrent_Spec (Body_Id : Entity_Id) return Entity_Id is
1909       Spec_Id : Entity_Id := Current_Entity_In_Scope (Body_Id);
1910
1911    begin
1912       --  The type may have been given by an incomplete type declaration.
1913       --  Find full view now.
1914
1915       if Present (Spec_Id) and then Ekind (Spec_Id) = E_Incomplete_Type then
1916          Spec_Id := Full_View (Spec_Id);
1917       end if;
1918
1919       return Spec_Id;
1920    end Find_Concurrent_Spec;
1921
1922    --------------------------
1923    -- Install_Declarations --
1924    --------------------------
1925
1926    procedure Install_Declarations (Spec : Entity_Id) is
1927       E    : Entity_Id;
1928       Prev : Entity_Id;
1929
1930    begin
1931       E := First_Entity (Spec);
1932
1933       while Present (E) loop
1934          Prev := Current_Entity (E);
1935          Set_Current_Entity (E);
1936          Set_Is_Immediately_Visible (E);
1937          Set_Homonym (E, Prev);
1938          Next_Entity (E);
1939       end loop;
1940    end Install_Declarations;
1941
1942 end Sem_Ch9;